git-gui: Define a simple class/method system

As most of the git-gui interface is based upon "meta-widgets"
that need to carry around a good deal of state (e.g. console
windows, browser windows, blame viewer) we have a good deal
of messy code that tries to store this meta-widget state in
global arrays, where keys into the array are formed from a
union of a unique "object instance id" and the field name.

This is a simple class system for Tcl that allows us to
hide much of that mess by making Tcl do what it does best;
process strings to manipulate its own code during startup.

Each object instance is placed into its own namespace.  The
namespace is created when the object instance is created and
the namespace is destroyed when the object instance is removed
from the system.  Within that namespace we place variables for
each field within the class; these variables can themselves be
scalar values or full-blown Tcl arrays.

A simple class might be defined as:

  class map {
    field data
    field size 0

    constructor {} {
      return $this
    }
    method set {name value} {
      set data($name) $value
      incr size
    }
    method size {} {
      return $size
    } ifdeleted { return 0 }
  }

All fields must be declared before any constructors or methods.  This
allows our class to generate a list of the fields so it can properly
alter the definition of the constructor and method bodies prior to
passing them off to Tcl for definition with proc. A field may optionally
be given a default/initial value.  This can only be done for non-array
type fields.

Constructors are given full access to all fields of the class, so they
can initialize the data values.  The default values of fields (if any)
are set before the constructor runs, and the implicit local variable
$this is initialized to the instance identifier.

Methods are given access to fields they actually use in their body.
Every method has an implicit "this" argument inserted as its first
parameter; callers of methods must be sure they supply this value.

Some basic optimization tricks are performed (but not much).  We
try to only upvar (locally bind) fields that are accessed within a
method, but we err on the side of caution and may upvar more than
we need to.  If a variable is accessed only once within a method
and that access is by $foo (read) we avoid the upvar and instead
use [set foo] to obtain the value.  This is slightly faster as Tcl
does not need to lookup the variable twice.

We also offer some small syntatic sugar for interacting with Tk and
the fileevent callback system in Tcl.  If a field (say "foo") is used
as "@foo" we insert instead the true global variable name of that
variable into the body of the constructor or method.  This allows easy
binding to Tk textvariable options, e.g.:

  label $w.title -textvariable @title

Proper namespace callbacks can also be setup with the special cb proc
that is defined in each namespace.  [cb _foo a] will invoke the method
_foo in the current namespace, passing it $this as the first (implied)
parameter and a as the second parameter.  This makes it very simple to
connect an object instance to a -command option for a Tk widget or to
a fileevent readable or writable for a file channel.

Signed-off-by: Shawn O. Pearce <spearce@spearce.org>

diff --git a/Makefile b/Makefile
index ba1e33ba8420b1505d785fd3559b3d50223cf2a0..e73b6453d9626cad1d2f71679afc0638f464f305 100644 (file)
--- a/Makefile
+++ b/Makefile
@@ -64,7 +64,10 @@ $(GITGUI_BUILT_INS): git-gui
        $(QUIET_BUILT_IN)rm -f $@ && ln git-gui $@
 
 lib/tclIndex: $(ALL_LIBFILES)
-       $(QUIET_INDEX)echo auto_mkindex lib '*.tcl' | $(TCL_PATH)
+       $(QUIET_INDEX)echo \
+         source lib/class.tcl \; \
+         auto_mkindex lib '*.tcl' \
+       | $(TCL_PATH)
 
 # These can record GITGUI_VERSION
 $(patsubst %.sh,%,$(SCRIPT_SH)): GIT-VERSION-FILE GIT-GUI-VARS

diff --git a/lib/class.tcl b/lib/class.tcl
new file mode 100644 (file)
index 0000000..c129198
--- /dev/null
+++ b/lib/class.tcl
@@ -0,0 +1,153 @@
+# 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
+                       set args [linsert $args 0 $name $this]
+                       return [uplevel [list namespace code $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]} \;
+       append mbodyc {namespace eval $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 {}
+
+       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} {
+                               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 delete_this {{t {}}} {
+       if {$t eq {}} {
+               upvar this this
+               set t $this
+       }
+       if {[namespace exists $t]} {namespace delete $t}
+}
+
+proc make_toplevel {t w} {
+       upvar $t top $w pfx
+       if {[winfo ismapped .]} {
+               upvar this this
+               regsub -all {::} $this {__} w
+               set top .$w
+               set pfx $top
+               toplevel $top
+       } else {
+               set top .
+               set pfx {}
+       }
+}
+
+
+## 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"
+}
+