git-gui: Teach class system to support [$this cmd] syntax

Its handy to be able to ask an object to do something for you by
handing it a subcommand.  For example if we want to get the value
of an object's private field the object could expose a method that
would return that value.  Application level code can then invoke
"$inst get" to perform the method call.

Tk uses this pattern for all of its widgets, so we'd certainly
like to use it for our own mega-widgets that we might develop.
Up until now we haven't needed such functionality, but I'm working
on a new revision picker mega-widget that would benefit from it.

To make this work we have to change the definition of $this to
actually be a procedure within the namespace.  By making $this a
procedure any caller that has $this can call subcommands by passing
them as the first argument to $this.  That subcommand then needs
to call the proper subroutine.

Placing the dispatch procedure into the object's variable namespace
ensures that it will always be deleted when the object is deleted.

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

1 files changed, 26 insertions, 12 deletions

diff --git a/lib/class.tcl b/lib/class.tcl
index 9d298d0..24e8cec 100644
--- a/lib/class.tcl
+++ b/lib/class.tcl
@@ -5,7 +5,7 @@ proc class {class body} {
 	if {[namespace exists $class]} {
 		error "class $class already declared"
 	}
-	namespace eval $class {
+	namespace eval $class "
 		variable __nextid     0
 		variable __sealed     0
 		variable __field_list {}
@@ -13,10 +13,9 @@ proc class {class body} {
 
 		proc cb {name args} {
 			upvar this this
-			set args [linsert $args 0 $name $this]
-			return [uplevel [list namespace code $args]]
+			concat \[list ${class}::\$name \$this\] \$args
 		}
-	}
+	"
 	namespace eval $class $body
 }
 
@@ -51,15 +50,16 @@ proc constructor {name params body} {
 	set mbodyc {}
 
 	append mbodyc {set this } $class
-	append mbodyc {::__o[incr } $class {::__nextid]} \;
-	append mbodyc {namespace eval $this {}} \;
+	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 { ${__this}::} $n { } $n
+			regsub -all @$n\\M $body "\${__this}::$n" body
 		}
 		append mbodyc \;
 		foreach n $__field_list {
@@ -80,10 +80,12 @@ proc method {name params body {deleted {}} {del_body {}}} {
 	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 {if {![namespace exists $__this]} }
 		append mbodyc \{ $del_body \; return \} \;
 	}
 	default {
@@ -98,10 +100,12 @@ proc method {name params body {deleted {}} {del_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
+				regsub -all \
+					\\\$$n\\M $body \
+					"\[set \${__this}::$n\]" body
 			} else {
-				append decl { ${this}::} $n { } $n
-				regsub -all @$n\\M $body "\${this}::$n" body
+				append decl { ${__this}::} $n { } $n
+				regsub -all @$n\\M $body "\${__this}::$n" body
 			}
 		}
 	}
@@ -112,11 +116,21 @@ proc method {name params body {deleted {}} {del_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}
 }