Combine the two bits of scripted code inside TclOO's definition into one.

4 files changed, 244 insertions, 175 deletions

diff --git a/generic/tclOO.c b/generic/tclOO.c
index 630e977..7702b2b 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -312,7 +312,7 @@ InitFoundation(
     ThreadLocalData *tsdPtr =
 	    Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
     Foundation *fPtr = ckalloc(sizeof(Foundation));
-    Tcl_Obj *namePtr, *argsPtr, *bodyPtr;
+    Tcl_Obj *namePtr;
     Tcl_DString buffer;
     Command *cmdPtr;
     int i;
@@ -392,18 +392,6 @@ InitFoundation(
     }
 
     /*
-     * Create the default <cloned> method implementation, used when 'oo::copy'
-     * is called to finish the copying of one object to another.
-     */
-
-    TclNewLiteralStringObj(argsPtr, "originObject");
-    Tcl_IncrRefCount(argsPtr);
-    bodyPtr = Tcl_NewStringObj(clonedBody, -1);
-    TclOONewProcMethod(interp, fPtr->objectCls, 0, fPtr->clonedName, argsPtr,
-	    bodyPtr, NULL);
-    TclDecrRefCount(argsPtr);
-
-    /*
      * Finish setting up the class of classes by marking the 'new' method as
      * private; classes, unlike general objects, must have explicit names. We
      * also need to create the constructor for classes.
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index 1f345fb..d89e81a 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -22,74 +22,103 @@
 
 static const char *tclOOSetupScript =
 /* !BEGIN!: Do not edit below this line. */
-"::proc ::oo::Helpers::callback {method args} {\n"
-"    list [uplevel 1 {namespace which my}] $method {*}$args\n"
-"}\n"
+"::namespace eval ::oo::Helpers {\n"
+"    ::namespace path {}\n"
 "\n"
-"::proc ::oo::Helpers::mymethod {method args} {\n"
-"    list [uplevel 1 {namespace which my}] $method {*}$args\n"
-"}\n"
+"    proc callback {method args} {\n"
+"        list [uplevel 1 {::namespace which my}] $method {*}$args\n"
+"    }\n"
 "\n"
-"::proc ::oo::Helpers::classvariable {name args} {\n"
-"    # 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"
-"    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"
+"    proc mymethod {method args} {\n"
+"        list [uplevel 1 {::namespace which my}] $method {*}$args\n"
 "    }\n"
-"    # Lastly, link the caller\'s local variables to the class\'s variables\n"
-"    tailcall namespace upvar $ns {*}$vs\n"
-"}\n"
 "\n"
-"::proc ::oo::Helpers::link {args} {\n"
-"    set ns [uplevel 1 {namespace current}]\n"
-"    foreach link $args {\n"
-"        if {[llength $link] == 2} {\n"
-"            lassign $link src dst\n"
-"        } else {\n"
-"            lassign $link src\n"
-"            set dst $src\n"
-"        }\n"
-"        if {![string match ::* $src]} {\n"
-"            set src [string cat $ns :: $src]\n"
+"    proc classvariable {name args} {\n"
+"        # 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"
+"        foreach v [list $name {*}$args] {\n"
+"            if {[string match *(*) $v]} {\n"
+"                variable \n"
+"                return -code error [format \\\n"
+"                    {bad variable name \"%s\": can\'t create a scalar variable that looks like an array element} \\\n"
+"                    $v]\n"
+"            }\n"
+"            if {[string match *::* $v]} {\n"
+"                return -code error [format \\\n"
+"                    {bad variable name \"%s\": can\'t create a local variable with a namespace separator in it} \\\n"
+"                    $v]\n"
+"            }\n"
+"            lappend vs $v $v\n"
 "        }\n"
-"        interp alias {} $src {} ${ns}::my $dst\n"
-"        trace add command ${ns}::my delete [list ::oo::Helpers::Unlink $src]\n"
+"        # Lastly, link the caller\'s local variables to the class\'s variables\n"
+"        tailcall namespace upvar $ns {*}$vs\n"
 "    }\n"
-"    return\n"
-"}\n"
-"::proc ::oo::Helpers::Unlink {cmd args} {\n"
-"    if {[namespace which $cmd] ne {}} {\n"
-"        rename $cmd {}\n"
+"\n"
+"    proc link {args} {\n"
+"        set ns [uplevel 1 {::namespace current}]\n"
+"        foreach link $args {\n"
+"            if {[llength $link] == 2} {\n"
+"                lassign $link src dst\n"
+"            } else {\n"
+"                lassign $link src\n"
+"                set dst $src\n"
+"            }\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 \\\n"
+"                ::oo::UnlinkLinkedCommand $src]\n"
+"        }\n"
+"        return\n"
 "    }\n"
 "}\n"
 "\n"
-"::proc ::oo::DelegateName {class} {\n"
-"    string cat [info object namespace $class] {:: oo ::delegate}\n"
-"}\n"
+"::namespace eval ::oo {\n"
+"    proc UnlinkLinkedCommand {cmd args} {\n"
+"        if {[namespace which $cmd] ne {}} {\n"
+"            rename $cmd {}\n"
+"        }\n"
+"    }\n"
 "\n"
-"proc ::oo::MixinClassDelegates {class} {\n"
-"    if {![info object isa class $class]} {\n"
-"        return\n"
+"    proc DelegateName {class} {\n"
+"        string cat [info object namespace $class] {:: oo ::delegate}\n"
 "    }\n"
-"    set delegate [::oo::DelegateName $class]\n"
-"    if {![info object isa class $delegate]} {\n"
-"        return\n"
+"\n"
+"    proc MixinClassDelegates {class} {\n"
+"        if {![info object isa class $class]} {\n"
+"            return\n"
+"        }\n"
+"        set delegate [DelegateName $class]\n"
+"        if {![info object isa class $delegate]} {\n"
+"            return\n"
+"        }\n"
+"        foreach c [info class superclass $class] {\n"
+"            set d [DelegateName $c]\n"
+"            if {![info object isa class $d]} {\n"
+"                continue\n"
+"            }\n"
+"            define $delegate superclass -append $d\n"
+"        }\n"
+"        objdefine $class mixin -append $delegate\n"
 "    }\n"
-"    foreach c [info class superclass $class] {\n"
-"        set d [::oo::DelegateName $c]\n"
-"        if {![info object isa class $d]} {\n"
-"            continue\n"
+"\n"
+"    proc UpdateClassDelegatesAfterClone {originObject targetObject} {\n"
+"        # Rebuild the class inheritance delegation class\n"
+"        set originDelegate [DelegateName $originObject]\n"
+"        set targetDelegate [DelegateName $targetObject]\n"
+"        if {\n"
+"            [info object isa class $originDelegate]\n"
+"            && ![info object isa class $targetDelegate]\n"
+"        } then {\n"
+"            copy $originDelegate $targetDelegate\n"
+"            objdefine $targetObject mixin -set \\\n"
+"                {*}[lmap c [info object mixin $targetObject] {\n"
+"                    if {$c eq $originDelegate} {set targetDelegate} {set c}\n"
+"                }]\n"
 "        }\n"
-"        ::oo::define $delegate superclass -append $d\n"
 "    }\n"
-"    ::oo::objdefine $class mixin -append $delegate\n"
 "}\n"
 "\n"
 "::namespace eval ::oo::define {\n"
@@ -97,8 +126,9 @@ static const char *tclOOSetupScript =
 "        # Create the method on the class if the caller gave arguments and body\n"
 "        ::set argc [::llength [::info level 0]]\n"
 "        ::if {$argc == 3} {\n"
-"            ::return -code error [::string cat {wrong # args: should be \"} \\\n"
-"                    [::lindex [::info level 0] 0] { name \?args body\?\"}]\n"
+"            ::return -code error [::format \\\n"
+"                {wrong # args: should be \"%s name \?args body\?\"} \\\n"
+"                [::lindex [::info level 0] 0]]\n"
 "        }\n"
 "        ::set cls [::uplevel 1 self]\n"
 "        ::if {$argc == 4} {\n"
@@ -151,17 +181,43 @@ static const char *tclOOSetupScript =
 "::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n"
 "::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n"
 "\n"
+"::oo::define ::oo::object method <cloned> {originObject} {\n"
+"    # Copy over the procedures from the original namespace\n"
+"    foreach p [info procs [info object namespace $originObject]::*] {\n"
+"        set args [info args $p]\n"
+"        set idx -1\n"
+"        foreach a $args {\n"
+"            if {[info default $p $a d]} {\n"
+"                lset args [incr idx] [list $a $d]\n"
+"            } else {\n"
+"                lset args [incr idx] [list $a]\n"
+"            }\n"
+"        }\n"
+"        set b [info body $p]\n"
+"        set p [namespace tail $p]\n"
+"        proc $p $args $b\n"
+"    }\n"
+"    # Copy over the variables from the original namespace\n"
+"    foreach v [info vars [info object namespace $originObject]::*] {\n"
+"        upvar 0 $v vOrigin\n"
+"        namespace upvar [namespace current] [namespace tail $v] vNew\n"
+"        if {[info exists vOrigin]} {\n"
+"            if {[array exists vOrigin]} {\n"
+"                array set vNew [array get vOrigin]\n"
+"            } else {\n"
+"                set vNew $vOrigin\n"
+"            }\n"
+"        }\n"
+"    }\n"
+"    # General commands, sub-namespaces and advancd variable config (traces,\n"
+"    # etc) are *not* copied over. Classes that want that should do it\n"
+"    # themselves.\n"
+"}\n"
+"\n"
 "::oo::define ::oo::class method <cloned> {originObject} {\n"
 "    next $originObject\n"
 "    # Rebuild the class inheritance delegation class\n"
-"    set originDelegate [::oo::DelegateName $originObject]\n"
-"    set targetDelegate [::oo::DelegateName [self]]\n"
-"    if {[info object isa class $originDelegate] && ![info object isa class $targetDelegate]} {\n"
-"        ::oo::copy $originDelegate $targetDelegate\n"
-"        ::oo::objdefine [self] mixin -set {*}[lmap c [info object mixin [self]] {\n"
-"            if {$c eq $originDelegate} {set targetDelegate} {set c}\n"
-"        }]\n"
-"    }\n"
+"    ::oo::UpdateClassDelegatesAfterClone $originObject [self]\n"
 "}\n"
 "\n"
 "::oo::class create ::oo::singleton {\n"
@@ -188,37 +244,6 @@ static const char *tclOOSetupScript =
 "}\n"
 /* !END!: Do not edit above this line. */
 ;
-
-/*
- * The body of the <cloned> method of oo::object.
- */
-
-static const char *clonedBody =
-"# Copy over the procedures from the original namespace\n"
-"foreach p [info procs [info object namespace $originObject]::*] {\n"
-"    set args [info args $p]\n"
-"    set idx -1\n"
-"    foreach a $args {\n"
-"        lset args [incr idx]"
-"            [if {[info default $p $a d]} {list $a $d} {list $a}]\n"
-"    }\n"
-"    set b [info body $p]\n"
-"    set p [namespace tail $p]\n"
-"    proc $p $args $b\n"
-"}\n"
-"# Copy over the variables from the original namespace\n"
-"foreach v [info vars [info object namespace $originObject]::*] {\n"
-"    upvar 0 $v vOrigin\n"
-"    namespace upvar [namespace current] [namespace tail $v] vNew\n"
-"    if {[info exists vOrigin]} {\n"
-"        if {[array exists vOrigin]} {\n"
-"            array set vNew [array get vOrigin]\n"
-"        } else {\n"
-"            set vNew $vOrigin\n"
-"        }\n"
-"    }\n"
-"}\n"
-;
 
 #endif /* TCL_OO_SCRIPT_H */
 
diff --git a/generic/tclOOScript.tcl b/generic/tclOOScript.tcl
index e0af23f..c0b4d1f 100644
--- a/generic/tclOOScript.tcl
+++ b/generic/tclOOScript.tcl
@@ -11,74 +11,103 @@
 # See the file "license.terms" for information on usage and redistribution of
 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
 
-::proc ::oo::Helpers::callback {method args} {
-    list [uplevel 1 {namespace which my}] $method {*}$args
-}
+::namespace eval ::oo::Helpers {
+    ::namespace path {}
 
-::proc ::oo::Helpers::mymethod {method args} {
-    list [uplevel 1 {namespace which my}] $method {*}$args
-}
+    proc callback {method args} {
+	list [uplevel 1 {::namespace which my}] $method {*}$args
+    }
 
-::proc ::oo::Helpers::classvariable {name args} {
-    # Get a reference to the class's namespace
-    set ns [info object namespace [uplevel 1 {self class}]]
-    # Double up the list of variable names
-    foreach v [list $name {*}$args] {
-        if {[string match *(*) $v]} {
-            return -code error [string cat {bad variable name "} $v {": can't create a scalar variable that looks like an array element}]
-        }
-        if {[string match *::* $v]} {
-            return -code error [string cat {bad variable name "} $v {": can't create a local variable with a namespace separator in it}]
-        }
-        lappend vs $v $v
+    proc mymethod {method args} {
+	list [uplevel 1 {::namespace which my}] $method {*}$args
     }
-    # Lastly, link the caller's local variables to the class's variables
-    tailcall namespace upvar $ns {*}$vs
-}
 
-::proc ::oo::Helpers::link {args} {
-    set ns [uplevel 1 {namespace current}]
-    foreach link $args {
-        if {[llength $link] == 2} {
-            lassign $link src dst
-        } else {
-            lassign $link src
-            set dst $src
-        }
-        if {![string match ::* $src]} {
-            set src [string cat $ns :: $src]
-        }
-        interp alias {} $src {} ${ns}::my $dst
-        trace add command ${ns}::my delete [list ::oo::Helpers::Unlink $src]
+    proc classvariable {name args} {
+	# Get a reference to the class's namespace
+	set ns [info object namespace [uplevel 1 {self class}]]
+	# Double up the list of variable names
+	foreach v [list $name {*}$args] {
+	    if {[string match *(*) $v]} {
+		variable 
+		return -code error [format \
+		    {bad variable name "%s": can't create a scalar variable that looks like an array element} \
+		    $v]
+	    }
+	    if {[string match *::* $v]} {
+		return -code error [format \
+		    {bad variable name "%s": can't create a local variable with a namespace separator in it} \
+		    $v]
+	    }
+	    lappend vs $v $v
+	}
+	# Lastly, link the caller's local variables to the class's variables
+	tailcall namespace upvar $ns {*}$vs
     }
-    return
-}
-::proc ::oo::Helpers::Unlink {cmd args} {
-    if {[namespace which $cmd] ne {}} {
-        rename $cmd {}
+
+    proc link {args} {
+	set ns [uplevel 1 {::namespace current}]
+	foreach link $args {
+	    if {[llength $link] == 2} {
+		lassign $link src dst
+	    } else {
+		lassign $link src
+		set dst $src
+	    }
+	    if {![string match ::* $src]} {
+		set src [string cat $ns :: $src]
+	    }
+	    interp alias {} $src {} ${ns}::my $dst
+	    trace add command ${ns}::my delete [list \
+		::oo::UnlinkLinkedCommand $src]
+	}
+	return
     }
 }
 
-::proc ::oo::DelegateName {class} {
-    string cat [info object namespace $class] {:: oo ::delegate}
-}
+::namespace eval ::oo {
+    proc UnlinkLinkedCommand {cmd args} {
+	if {[namespace which $cmd] ne {}} {
+	    rename $cmd {}
+	}
+    }
 
-proc ::oo::MixinClassDelegates {class} {
-    if {![info object isa class $class]} {
-        return
+    proc DelegateName {class} {
+	string cat [info object namespace $class] {:: oo ::delegate}
     }
-    set delegate [::oo::DelegateName $class]
-    if {![info object isa class $delegate]} {
-        return
+
+    proc MixinClassDelegates {class} {
+	if {![info object isa class $class]} {
+	    return
+	}
+	set delegate [DelegateName $class]
+	if {![info object isa class $delegate]} {
+	    return
+	}
+	foreach c [info class superclass $class] {
+	    set d [DelegateName $c]
+	    if {![info object isa class $d]} {
+		continue
+	    }
+	    define $delegate superclass -append $d
+	}
+	objdefine $class mixin -append $delegate
     }
-    foreach c [info class superclass $class] {
-        set d [::oo::DelegateName $c]
-        if {![info object isa class $d]} {
-            continue
-        }
-        ::oo::define $delegate superclass -append $d
+
+    proc UpdateClassDelegatesAfterClone {originObject targetObject} {
+	# Rebuild the class inheritance delegation class
+	set originDelegate [DelegateName $originObject]
+	set targetDelegate [DelegateName $targetObject]
+	if {
+	    [info object isa class $originDelegate]
+	    && ![info object isa class $targetDelegate]
+	} then {
+	    copy $originDelegate $targetDelegate
+	    objdefine $targetObject mixin -set \
+		{*}[lmap c [info object mixin $targetObject] {
+		    if {$c eq $originDelegate} {set targetDelegate} {set c}
+		}]
+	}
     }
-    ::oo::objdefine $class mixin -append $delegate
 }
 
 ::namespace eval ::oo::define {
@@ -86,8 +115,9 @@ proc ::oo::MixinClassDelegates {class} {
         # Create the method on the class if the caller gave arguments and body
         ::set argc [::llength [::info level 0]]
         ::if {$argc == 3} {
-            ::return -code error [::string cat {wrong # args: should be "} \
-                    [::lindex [::info level 0] 0] { name ?args body?"}]
+            ::return -code error [::format \
+		{wrong # args: should be "%s name ?args body?"} \
+                [::lindex [::info level 0] 0]]
         }
         ::set cls [::uplevel 1 self]
         ::if {$argc == 4} {
@@ -140,17 +170,43 @@ proc ::oo::MixinClassDelegates {class} {
 ::oo::objdefine ::oo::define::mixin forward --default-operation my -set
 ::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set
 
+::oo::define ::oo::object method <cloned> {originObject} {
+    # Copy over the procedures from the original namespace
+    foreach p [info procs [info object namespace $originObject]::*] {
+	set args [info args $p]
+	set idx -1
+	foreach a $args {
+	    if {[info default $p $a d]} {
+		lset args [incr idx] [list $a $d]
+	    } else {
+		lset args [incr idx] [list $a]
+	    }
+	}
+	set b [info body $p]
+	set p [namespace tail $p]
+	proc $p $args $b
+    }
+    # Copy over the variables from the original namespace
+    foreach v [info vars [info object namespace $originObject]::*] {
+	upvar 0 $v vOrigin
+	namespace upvar [namespace current] [namespace tail $v] vNew
+	if {[info exists vOrigin]} {
+	    if {[array exists vOrigin]} {
+		array set vNew [array get vOrigin]
+	    } else {
+		set vNew $vOrigin
+	    }
+	}
+    }
+    # General commands, sub-namespaces and advancd variable config (traces,
+    # etc) are *not* copied over. Classes that want that should do it
+    # themselves.
+}
+
 ::oo::define ::oo::class method <cloned> {originObject} {
     next $originObject
     # Rebuild the class inheritance delegation class
-    set originDelegate [::oo::DelegateName $originObject]
-    set targetDelegate [::oo::DelegateName [self]]
-    if {[info object isa class $originDelegate] && ![info object isa class $targetDelegate]} {
-        ::oo::copy $originDelegate $targetDelegate
-        ::oo::objdefine [self] mixin -set {*}[lmap c [info object mixin [self]] {
-            if {$c eq $originDelegate} {set targetDelegate} {set c}
-        }]
-    }
+    ::oo::UpdateClassDelegatesAfterClone $originObject [self]
 }
 
 ::oo::class create ::oo::singleton {
diff --git a/tools/makeHeader.tcl b/tools/makeHeader.tcl
index 8af35fc..5197da6 100644
--- a/tools/makeHeader.tcl
+++ b/tools/makeHeader.tcl
@@ -21,7 +21,7 @@ namespace eval makeHeader {
 	# All Tcl metacharacters and key C backslash sequences
 	set MAP {
 	    \" \\\\\" \\ \\\\\\\\ $ \\$ [ \\[ ] \\] ' \\\\' ? \\\\?
-	    \a \\\\a \b \\\\b \f \\\\f \n \\\\n \r \\\\r \t \\\\t \v \\\\v
+	    \a \\\\a \b \\\\b \f \\\\f \n \\\\n \r \\\\r \t {        } \v \\\\v
 	}
 	set XFORM {[format \\\\\\\\u%04x {*}[scan & %c]]}