summaryrefslogtreecommitdiff
path: root/git-gui/lib/class.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'git-gui/lib/class.tcl')
-rw-r--r--git-gui/lib/class.tcl193
1 files changed, 193 insertions, 0 deletions
diff --git a/git-gui/lib/class.tcl b/git-gui/lib/class.tcl
new file mode 100644
index 0000000..c27b714
--- /dev/null
+++ b/git-gui/lib/class.tcl
@@ -0,0 +1,193 @@
+# 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]
+ 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"
+}