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

1 files changed, 120 insertions, 95 deletions

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 */