X-Git-Url: https://asedeno.scripts.mit.edu/gitweb/?a=blobdiff_plain;f=lib%2Fclass.tcl;h=c27b71476ac35dbad02b727f28aba5d7c0777e75;hb=9cb268c426ccb2bb836418caad669476b5dd1933;hp=c1291989aa0831af1986c30fff544d9f3678d5c3;hpb=1f07c4e5cefec88d825045ade24eee71f6a2df47;p=git.git

diff --git a/lib/class.tcl b/lib/class.tcl
index c1291989a..c27b71476 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 {
@@ -96,11 +98,14 @@ proc method {name params body {deleted {}} {del_body {}}} {
 		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
+				&& [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
+				append decl { ${__this}::} $n { } $n
+				regsub -all @$n\\M $body "\${__this}::$n" body
 			}
 		}
 	}
@@ -111,26 +116,62 @@ 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}
 }
 
-proc make_toplevel {t w} {
-	upvar $t top $w pfx
-	if {[winfo ismapped .]} {
-		upvar this this
+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]
+		"
+	}
 }
 
 
@@ -150,4 +191,3 @@ auto_mkindex_parser::command constructor {name args} {
 		[format { [list source [file join $dir %s]]} \
 		[file split $scriptFile]] "\n"
 }
-