lib/class.tcl

   1 # git-gui simple class/object fake-alike
   2 # Copyright (C) 2007 Shawn Pearce
   3
   4 proc class {class body} {
   5         if {[namespace exists $class]} {
   6                 error "class $class already declared"
   7         }
   8         namespace eval $class {
   9                 variable __nextid     0
  10                 variable __sealed     0
  11                 variable __field_list {}
  12                 variable __field_array
  13
  14                 proc cb {name args} {
  15                         upvar this this
  16                         set args [linsert $args 0 $name $this]
  17                         return [uplevel [list namespace code $args]]
  18                 }
  19         }
  20         namespace eval $class $body
  21 }
  22
  23 proc field {name args} {
  24         set class [uplevel {namespace current}]
  25         variable ${class}::__sealed
  26         variable ${class}::__field_array
  27
  28         switch [llength $args] {
  29         0 { set new [list $name] }
  30         1 { set new [list $name [lindex $args 0]] }
  31         default { error "wrong # args: field name value?" }
  32         }
  33
  34         if {$__sealed} {
  35                 error "class $class is sealed (cannot add new fields)"
  36         }
  37
  38         if {[catch {set old $__field_array($name)}]} {
  39                 variable ${class}::__field_list
  40                 lappend __field_list $new
  41                 set __field_array($name) 1
  42         } else {
  43                 error "field $name already declared"
  44         }
  45 }
  46
  47 proc constructor {name params body} {
  48         set class [uplevel {namespace current}]
  49         set ${class}::__sealed 1
  50         variable ${class}::__field_list
  51         set mbodyc {}
  52
  53         append mbodyc {set this } $class
  54         append mbodyc {::__o[incr } $class {::__nextid]} \;
  55         append mbodyc {namespace eval $this {}} \;
  56
  57         if {$__field_list ne {}} {
  58                 append mbodyc {upvar #0}
  59                 foreach n $__field_list {
  60                         set n [lindex $n 0]
  61                         append mbodyc { ${this}::} $n { } $n
  62                         regsub -all @$n\\M $body "\${this}::$n" body
  63                 }
  64                 append mbodyc \;
  65                 foreach n $__field_list {
  66                         if {[llength $n] == 2} {
  67                                 append mbodyc \
  68                                 {set } [lindex $n 0] { } [list [lindex $n 1]] \;
  69                         }
  70                 }
  71         }
  72         append mbodyc $body
  73         namespace eval $class [list proc $name $params $mbodyc]
  74 }
  75
  76 proc method {name params body {deleted {}} {del_body {}}} {
  77         set class [uplevel {namespace current}]
  78         set ${class}::__sealed 1
  79         variable ${class}::__field_list
  80         set params [linsert $params 0 this]
  81         set mbodyc {}
  82
  83         switch $deleted {
  84         {} {}
  85         ifdeleted {
  86                 append mbodyc {if {![namespace exists $this]} }
  87                 append mbodyc \{ $del_body \; return \} \;
  88         }
  89         default {
  90                 error "wrong # args: method name args body (ifdeleted body)?"
  91         }
  92         }
  93
  94         set decl {}
  95         foreach n $__field_list {
  96                 set n [lindex $n 0]
  97                 if {[regexp -- $n\\M $body]} {
  98                         if {   [regexp -all -- $n\\M $body] == 1
  99                                 && [regexp -all -- \\\$$n\\M $body] == 1
 100                                 && [regexp -all -- \\\$$n\\( $body] == 0} {
 101                                 regsub -all \\\$$n\\M $body "\[set \${this}::$n\]" body
 102                         } else {
 103                                 append decl { ${this}::} $n { } $n
 104                                 regsub -all @$n\\M $body "\${this}::$n" body
 105                         }
 106                 }
 107         }
 108         if {$decl ne {}} {
 109                 append mbodyc {upvar #0} $decl \;
 110         }
 111         append mbodyc $body
 112         namespace eval $class [list proc $name $params $mbodyc]
 113 }
 114
 115 proc delete_this {{t {}}} {
 116         if {$t eq {}} {
 117                 upvar this this
 118                 set t $this
 119         }
 120         if {[namespace exists $t]} {namespace delete $t}
 121 }
 122
 123 proc make_toplevel {t w args} {
 124         upvar $t top $w pfx this this
 125
 126         if {[llength $args] % 2} {
 127                 error "make_toplevel topvar winvar {options}"
 128         }
 129         set autodelete 1
 130         foreach {name value} $args {
 131                 switch -exact -- $name {
 132                 -autodelete {set autodelete $value}
 133                 default     {error "unsupported option $name"}
 134                 }
 135         }
 136
 137         if {[winfo ismapped .]} {
 138                 regsub -all {::} $this {__} w
 139                 set top .$w
 140                 set pfx $top
 141                 toplevel $top
 142         } else {
 143                 set top .
 144                 set pfx {}
 145         }
 146
 147         if {$autodelete} {
 148                 wm protocol $top WM_DELETE_WINDOW "
 149                         [list delete_this $this]
 150                         [list destroy $top]
 151                 "
 152         }
 153 }
 154
 155
 156 ## auto_mkindex support for class/constructor/method
 157 ##
 158 auto_mkindex_parser::command class {name body} {
 159         variable parser
 160         variable contextStack
 161         set contextStack [linsert $contextStack 0 $name]
 162         $parser eval [list _%@namespace eval $name] $body
 163         set contextStack [lrange $contextStack 1 end]
 164 }
 165 auto_mkindex_parser::command constructor {name args} {
 166         variable index
 167         variable scriptFile
 168         append index [list set auto_index([fullname $name])] \
 169                 [format { [list source [file join $dir %s]]} \
 170                 [file split $scriptFile]] "\n"
 171 }