diff options
Diffstat (limited to 'git-gui/lib/class.tcl')
| -rw-r--r-- | git-gui/lib/class.tcl | 194 |
1 files changed, 194 insertions, 0 deletions
diff --git a/git-gui/lib/class.tcl b/git-gui/lib/class.tcl new file mode 100644 index 0000000..f08506f --- /dev/null +++ b/git-gui/lib/class.tcl @@ -0,0 +1,194 @@ +# git-gui simple class/object fake-alike +# Copyright (C) 2007 Shawn Pearce + +proc class {class body} { + if {[namespace exists $class]} { + error "class $class already declared" + } + namespace eval $class " + variable __nextid 0 + variable __sealed 0 + variable __field_list {} + variable __field_array + + proc cb {name args} { + upvar this this + concat \[list ${class}::\$name \$this\] \$args + } + " + namespace eval $class $body +} + +proc field {name args} { + set class [uplevel {namespace current}] + variable ${class}::__sealed + variable ${class}::__field_array + + switch [llength $args] { + 0 { set new [list $name] } + 1 { set new [list $name [lindex $args 0]] } + default { error "wrong # args: field name value?" } + } + + if {$__sealed} { + error "class $class is sealed (cannot add new fields)" + } + + if {[catch {set old $__field_array($name)}]} { + variable ${class}::__field_list + lappend __field_list $new + set __field_array($name) 1 + } else { + error "field $name already declared" + } +} + +proc constructor {name params body} { + set class [uplevel {namespace current}] + set ${class}::__sealed 1 + variable ${class}::__field_list + set mbodyc {} + + append mbodyc {set this } $class + append mbodyc {::__o[incr } $class {::__nextid]::__d} \; + append mbodyc {create_this } $class \; + append mbodyc {set __this [namespace qualifiers $this]} \; + + if {$__field_list ne {}} { + append mbodyc {upvar #0} + foreach n $__field_list { + set n [lindex $n 0] + append mbodyc { ${__this}::} $n { } $n + regsub -all @$n\\M $body "\${__this}::$n" body + } + append mbodyc \; + foreach n $__field_list { + if {[llength $n] == 2} { + append mbodyc \ + {set } [lindex $n 0] { } [list [lindex $n 1]] \; + } + } + } + append mbodyc $body + namespace eval $class [list proc $name $params $mbodyc] +} + +proc method {name params body {deleted {}} {del_body {}}} { + set class [uplevel {namespace current}] + set ${class}::__sealed 1 + variable ${class}::__field_list + set params [linsert $params 0 this] + set mbodyc {} + + append mbodyc {set __this [namespace qualifiers $this]} \; + + switch $deleted { + {} {} + ifdeleted { + append mbodyc {if {![namespace exists $__this]} } + append mbodyc \{ $del_body \; return \} \; + } + default { + error "wrong # args: method name args body (ifdeleted body)?" + } + } + + set decl {} + foreach n $__field_list { + set n [lindex $n 0] + if {[regexp -- $n\\M $body]} { + if { [regexp -all -- $n\\M $body] == 1 + && [regexp -all -- \\\$$n\\M $body] == 1 + && [regexp -all -- \\\$$n\\( $body] == 0} { + regsub -all \ + \\\$$n\\M $body \ + "\[set \${__this}::$n\]" body + } else { + append decl { ${__this}::} $n { } $n + regsub -all @$n\\M $body "\${__this}::$n" body + } + } + } + if {$decl ne {}} { + append mbodyc {upvar #0} $decl \; + } + append mbodyc $body + namespace eval $class [list proc $name $params $mbodyc] +} + +proc create_this {class} { + upvar this this + namespace eval [namespace qualifiers $this] [list proc \ + [namespace tail $this] \ + [list name args] \ + "eval \[list ${class}::\$name $this\] \$args" \ + ] +} + +proc delete_this {{t {}}} { + if {$t eq {}} { + upvar this this + set t $this + } + set t [namespace qualifiers $t] + if {[namespace exists $t]} {namespace delete $t} +} + +proc make_dialog {t w args} { + upvar $t top $w pfx this this + global use_ttk + uplevel [linsert $args 0 make_toplevel $t $w] + catch {wm attributes $top -type dialog} + pave_toplevel $pfx +} + +proc make_toplevel {t w args} { + upvar $t top $w pfx this this + + if {[llength $args] % 2} { + error "make_toplevel topvar winvar {options}" + } + set autodelete 1 + foreach {name value} $args { + switch -exact -- $name { + -autodelete {set autodelete $value} + default {error "unsupported option $name"} + } + } + + if {$::root_exists || [winfo ismapped .]} { + regsub -all {::} $this {__} w + set top .$w + set pfx $top + toplevel $top + set ::root_exists 1 + } else { + set top . + set pfx {} + } + + if {$autodelete} { + wm protocol $top WM_DELETE_WINDOW " + [list delete_this $this] + [list destroy $top] + " + } +} + + +## auto_mkindex support for class/constructor/method +## +auto_mkindex_parser::command class {name body} { + variable parser + variable contextStack + set contextStack [linsert $contextStack 0 $name] + $parser eval [list _%@namespace eval $name] $body + set contextStack [lrange $contextStack 1 end] +} +auto_mkindex_parser::command constructor {name args} { + variable index + variable scriptFile + append index [list set auto_index([fullname $name])] \ + [format { [list source [file join $dir %s]]} \ + [file split $scriptFile]] "\n" +} |