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                         concat \[list ${class}::\$name \$this\] \$args
  17                 }
  18         "
  19         namespace eval $class $body
  20 }
  21
  22 proc field {name args} {
  23         set class [uplevel {namespace current}]
  24         variable ${class}::__sealed
  25         variable ${class}::__field_array
  26
  27         switch [llength $args] {
  28         0 { set new [list $name] }
  29         1 { set new [list $name [lindex $args 0]] }
  30         default { error "wrong # args: field name value?" }
  31         }
  32
  33         if {$__sealed} {
  34                 error "class $class is sealed (cannot add new fields)"
  35         }
  36
  37         if {[catch {set old $__field_array($name)}]} {
  38                 variable ${class}::__field_list
  39                 lappend __field_list $new
  40                 set __field_array($name) 1
  41         } else {
  42                 error "field $name already declared"
  43         }
  44 }
  45
  46 proc constructor {name params body} {
  47         set class [uplevel {namespace current}]
  48         set ${class}::__sealed 1
  49         variable ${class}::__field_list
  50         set mbodyc {}
  51
  52         append mbodyc {set this } $class
  53         append mbodyc {::__o[incr } $class {::__nextid]::__d} \;
  54         append mbodyc {create_this } $class \;
  55         append mbodyc {set __this [namespace qualifiers $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         append mbodyc {set __this [namespace qualifiers $this]} \;
  84
  85         switch $deleted {
  86         {} {}
  87         ifdeleted {
  88                 append mbodyc {if {![namespace exists $__this]} }
  89                 append mbodyc \{ $del_body \; return \} \;
  90         }
  91         default {
  92                 error "wrong # args: method name args body (ifdeleted body)?"
  93         }
  94         }
  95
  96         set decl {}
  97         foreach n $__field_list {
  98                 set n [lindex $n 0]
  99                 if {[regexp -- $n\\M $body]} {
 100                         if {   [regexp -all -- $n\\M $body] == 1
 101                                 && [regexp -all -- \\\$$n\\M $body] == 1
 102                                 && [regexp -all -- \\\$$n\\( $body] == 0} {
 103                                 regsub -all \
 104                                         \\\$$n\\M $body \
 105                                         "\[set \${__this}::$n\]" body
 106                         } else {
 107                                 append decl { ${__this}::} $n { } $n
 108                                 regsub -all @$n\\M $body "\${__this}::$n" body
 109                         }
 110                 }
 111         }
 112         if {$decl ne {}} {
 113                 append mbodyc {upvar #0} $decl \;
 114         }
 115         append mbodyc $body
 116         namespace eval $class [list proc $name $params $mbodyc]
 117 }
 118
 119 proc create_this {class} {
 120         upvar this this
 121         namespace eval [namespace qualifiers $this] [list proc \
 122                 [namespace tail $this] \
 123                 [list name args] \
 124                 "eval \[list ${class}::\$name $this\] \$args" \
 125         ]
 126 }
 127
 128 proc delete_this {{t {}}} {
 129         if {$t eq {}} {
 130                 upvar this this
 131                 set t $this
 132         }
 133         set t [namespace qualifiers $t]
 134         if {[namespace exists $t]} {namespace delete $t}
 135 }
 136
 137 proc make_toplevel {t w args} {
 138         upvar $t top $w pfx this this
 139
 140         if {[llength $args] % 2} {
 141                 error "make_toplevel topvar winvar {options}"
 142         }
 143         set autodelete 1
 144         foreach {name value} $args {
 145                 switch -exact -- $name {
 146                 -autodelete {set autodelete $value}
 147                 default     {error "unsupported option $name"}
 148                 }
 149         }
 150
 151         if {[winfo ismapped .]} {
 152                 regsub -all {::} $this {__} w
 153                 set top .$w
 154                 set pfx $top
 155                 toplevel $top
 156         } else {
 157                 set top .
 158                 set pfx {}
 159         }
 160
 161         if {$autodelete} {
 162                 wm protocol $top WM_DELETE_WINDOW "
 163                         [list delete_this $this]
 164                         [list destroy $top]
 165                 "
 166         }
 167 }
 168
 169
 170 ## auto_mkindex support for class/constructor/method
 171 ##
 172 auto_mkindex_parser::command class {name body} {
 173         variable parser
 174         variable contextStack
 175         set contextStack [linsert $contextStack 0 $name]
 176         $parser eval [list _%@namespace eval $name] $body
 177         set contextStack [lrange $contextStack 1 end]
 178 }
 179 auto_mkindex_parser::command constructor {name args} {
 180         variable index
 181         variable scriptFile
 182         append index [list set auto_index([fullname $name])] \
 183                 [format { [list source [file join $dir %s]]} \
 184                 [file split $scriptFile]] "\n"
 185 }