More test cases. More fixes.

2 files changed, 118 insertions, 4 deletions

diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index 22f5e56..6dd105e 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -33,8 +33,15 @@ static const char *tclOOSetupScript =
 "    # Get a reference to the class's namespace\n"
 "    set ns [info object namespace [uplevel 1 {self class}]]\n"
 "    # Double up the list of variable names\n"
-"    set vs [list $name $name]\n"
-"    foreach v $args {lappend vs $v $v}\n"
+"    foreach v [list $name {*}$args] {\n"
+"        if {[string match *(*) $v]} {\n"
+"            return -code error [string cat {bad variable name \"} $v {\": can\'t create a scalar variable that looks like an array element}]\n"
+"        }\n"
+"        if {[string match *::* $v]} {\n"
+"            return -code error [string cat {bad variable name \"} $v {\": can\'t create a local variable with a namespace separator in it}]\n"
+"        }\n"
+"        lappend vs $v $v\n"
+"    }\n"
 "    # Lastly, link the caller's local variables to the class's variables\n"
 "    tailcall namespace upvar $ns {*}$vs\n"
 "}\n"
@@ -48,12 +55,21 @@ static const char *tclOOSetupScript =
 "            lassign $link src\n"
 "            set dst $src\n"
 "        }\n"
-"        interp alias {} ${ns}::$src {} ${ns}::my $dst\n"
+"        if {![string match ::* $src]} {\n"
+"            set src [string cat $ns :: $src]\n"
+"        }\n"
+"        interp alias {} $src {} ${ns}::my $dst\n"
+"        trace add command ${ns}::my delete [list ::oo::Helpers::Unlink $src]\n"
 "    }\n"
 "    return\n"
 "}\n"
+"::proc ::oo::Helpers::Unlink {cmd args} {\n"
+"    if {[namespace which $cmd] ne {}} {\n"
+"        rename $cmd {}\n"
+"    }\n"
+"}\n"
 
-"proc ::oo::DelegateName {class} {\n"
+"::proc ::oo::DelegateName {class} {\n"
 "    string cat [info object namespace $class] {:: oo ::delegate}\n"
 "}\n"
 
diff --git a/tests/ooUtil.test b/tests/ooUtil.test
index 4e4dba1..77fa175 100644
--- a/tests/ooUtil.test
+++ b/tests/ooUtil.test
@@ -301,6 +301,104 @@ test ooUtil-5.1 {TIP 478: abstract} -setup {
     parent destroy
 } -result {1 1 1 123 456 ::y}
 
+test ooUtil-6.1 {TIP 478: classvarable} -setup {
+    oo::class create parent
+} -body {
+    oo::class create xyz {
+	superclass parent
+	initialise {
+	    variable x 1 y 2
+	}
+	method a {} {
+	    classvariable x
+	    incr x
+	}
+	method b {} {
+	    classvariable y
+	    incr y
+	}
+	method c {} {
+	    classvariable x y
+	    list $x $y
+	}
+    }
+    set p [xyz new]
+    set q [xyz new]
+    set result [list [$p c] [$q c]]
+    $p a
+    $q b
+    lappend result [[xyz new] c]
+} -cleanup {
+    parent destroy
+} -result {{1 2} {1 2} {2 3}}
+test ooUtil-6.2 {TIP 478: classvarable error case} -setup {
+    oo::class create parent
+} -body {
+    oo::class create xyz {
+	superclass parent
+	method a {} {
+	    classvariable x(1)
+	    incr x(1)
+	}
+    }
+    set p [xyz new]
+    set q [xyz new]
+    list [$p a] [$q a]
+} -returnCodes error -cleanup {
+    parent destroy
+} -result {bad variable name "x(1)": can't create a scalar variable that looks like an array element}
+test ooUtil-6.3 {TIP 478: classvarable error case} -setup {
+    oo::class create parent
+} -body {
+    oo::class create xyz {
+	superclass parent
+	method a {} {
+	    classvariable ::x
+	    incr x
+	}
+    }
+    set p [xyz new]
+    set q [xyz new]
+    list [$p a] [$q a]
+} -returnCodes error -cleanup {
+    parent destroy
+} -result {bad variable name "::x": can't create a local variable with a namespace separator in it}
+
+test ooUtil-7.1 {TIP 478: link calling pattern} -setup {
+    oo::class create parent
+} -body {
+    oo::class create cls {
+	superclass parent
+	method foo {} {return "in foo of [self]"}
+	method Bar {} {return "in bar of [self]"}
+	method Grill {} {return "in grill of [self]"}
+	export eval
+	constructor {} {
+	    link foo
+	    link {bar Bar} {grill Grill}
+	}
+    }
+    cls create o
+    o eval {list [foo] [bar] [grill]}
+} -cleanup {
+    parent destroy
+} -result {{in foo of ::o} {in bar of ::o} {in grill of ::o}}
+test ooUtil-7.2 {TIP 478: link removed when [my] disappears} -setup {
+    oo::class create parent
+} -body {
+    oo::class create cls {
+	superclass parent
+	method foo {} {return "in foo of [self]"}
+	constructor {cmd} {
+	    link [list ::$cmd foo]
+	}
+    }
+    cls create o pqr
+    list [o foo] [pqr] [rename [info object namespace o]::my {}] [catch pqr msg] $msg
+} -cleanup {
+    parent destroy
+} -result {{in foo of ::o} {in foo of ::o} {} 1 {invalid command name "pqr"}}
+
 # Tests that verify issues detected with the tcllib version of the code
 test ooUtil-tcllib-ticket-b3577ed586 {test scoping of delegation in oo::class.Delegate } -setup {
     oo::class create animal {}