Merge trunk

1 files changed, 39 insertions, 181 deletions

diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index a9b262c..390b034 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -27,157 +27,6 @@
 static const char *tclOOSetupScript =
 /* !BEGIN!: Do not edit below this line. */
 "::namespace eval ::oo {\n"
-"\tproc Helpers::classvariable {name args} {\n"
-"\t\tset ns [info object namespace [uplevel 1 {self class}]]\n"
-"\t\tforeach v [list $name {*}$args] {\n"
-"\t\t\tif {[string match *(*) $v]} {\n"
-"\t\t\t\tset reason \"can\'t create a scalar variable that looks like an array element\"\n"
-"\t\t\t\treturn -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \\\n"
-"\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n"
-"\t\t\t}\n"
-"\t\t\tif {[string match *::* $v]} {\n"
-"\t\t\t\tset reason \"can\'t create a local variable with a namespace separator in it\"\n"
-"\t\t\t\treturn -code error -errorcode {TCL UPVAR INVERTED} \\\n"
-"\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n"
-"\t\t\t}\n"
-"\t\t\tlappend vs $v $v\n"
-"\t\t}\n"
-"\t\ttailcall namespace upvar $ns {*}$vs\n"
-"\t}\n"
-"\tproc Helpers::link {args} {\n"
-"\t\tset ns [uplevel 1 {::namespace current}]\n"
-"\t\tforeach link $args {\n"
-"\t\t\tif {[llength $link] == 2} {\n"
-"\t\t\t\tlassign $link src dst\n"
-"\t\t\t} elseif {[llength $link] == 1} {\n"
-"\t\t\t\tlassign $link src\n"
-"\t\t\t\tset dst $src\n"
-"\t\t\t} else {\n"
-"\t\t\t\treturn -code error -errorcode {TCL OO CMDLINK_FORMAT} \\\n"
-"\t\t\t\t\t\"bad link description; must only have one or two elements\"\n"
-"\t\t\t}\n"
-"\t\t\tif {![string match ::* $src]} {\n"
-"\t\t\t\tset src [string cat $ns :: $src]\n"
-"\t\t\t}\n"
-"\t\t\tinterp alias {} $src {} ${ns}::my $dst\n"
-"\t\t\ttrace add command ${ns}::my delete [list \\\n"
-"\t\t\t\t::oo::UnlinkLinkedCommand $src]\n"
-"\t\t}\n"
-"\t}\n"
-"\tproc UnlinkLinkedCommand {cmd args} {\n"
-"\t\tif {[namespace which $cmd] ne {}} {\n"
-"\t\t\trename $cmd {}\n"
-"\t\t}\n"
-"\t}\n"
-"\tproc DelegateName {class} {\n"
-"\t\tstring cat [info object namespace $class] {:: oo ::delegate}\n"
-"\t}\n"
-"\tproc MixinClassDelegates {class} {\n"
-"\t\tif {![info object isa class $class]} {\n"
-"\t\t\treturn\n"
-"\t\t}\n"
-"\t\tset delegate [DelegateName $class]\n"
-"\t\tif {![info object isa class $delegate]} {\n"
-"\t\t\treturn\n"
-"\t\t}\n"
-"\t\tforeach c [info class superclass $class] {\n"
-"\t\t\tset d [DelegateName $c]\n"
-"\t\t\tif {![info object isa class $d]} {\n"
-"\t\t\t\tcontinue\n"
-"\t\t\t}\n"
-"\t\t\tdefine $delegate ::oo::define::superclass -appendifnew $d\n"
-"\t\t}\n"
-"\t\tobjdefine $class ::oo::objdefine::mixin -appendifnew $delegate\n"
-"\t}\n"
-"\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n"
-"\t\tset originDelegate [DelegateName $originObject]\n"
-"\t\tset targetDelegate [DelegateName $targetObject]\n"
-"\t\tif {\n"
-"\t\t\t[info object isa class $originDelegate]\n"
-"\t\t\t&& ![info object isa class $targetDelegate]\n"
-"\t\t} then {\n"
-"\t\t\tcopy $originDelegate $targetDelegate\n"
-"\t\t\tobjdefine $targetObject ::oo::objdefine::mixin -set \\\n"
-"\t\t\t\t{*}[lmap c [info object mixin $targetObject] {\n"
-"\t\t\t\t\tif {$c eq $originDelegate} {set targetDelegate} {set c}\n"
-"\t\t\t\t}]\n"
-"\t\t}\n"
-"\t}\n"
-"\tproc define::classmethod {name args} {\n"
-"\t\t::set argc [::llength [::info level 0]]\n"
-"\t\t::if {$argc == 3} {\n"
-"\t\t\t::return -code error -errorcode {TCL WRONGARGS} [::format \\\n"
-"\t\t\t\t{wrong # args: should be \"%s name \?args body\?\"} \\\n"
-"\t\t\t\t[::lindex [::info level 0] 0]]\n"
-"\t\t}\n"
-"\t\t::set cls [::uplevel 1 self]\n"
-"\t\t::if {$argc == 4} {\n"
-"\t\t\t::oo::define [::oo::DelegateName $cls] method $name {*}$args\n"
-"\t\t}\n"
-"\t\t::tailcall forward $name myclass $name\n"
-"\t}\n"
-"\tdefine Slot {\n"
-"\t\tmethod Get -unexport {} {\n"
-"\t\t\treturn -code error -errorcode {TCL OO ABSTRACT_SLOT} \"unimplemented\"\n"
-"\t\t}\n"
-"\t\tmethod Set -unexport list {\n"
-"\t\t\treturn -code error -errorcode {TCL OO ABSTRACT_SLOT} \"unimplemented\"\n"
-"\t\t}\n"
-"\t\tmethod Resolve -unexport list {\n"
-"\t\t\treturn $list\n"
-"\t\t}\n"
-"\t\tmethod -set -export args {\n"
-"\t\t\tset my [namespace which my]\n"
-"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
-"\t\t\ttailcall my Set $args\n"
-"\t\t}\n"
-"\t\tmethod -append -export args {\n"
-"\t\t\tset my [namespace which my]\n"
-"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
-"\t\t\tset current [uplevel 1 [list $my Get]]\n"
-"\t\t\ttailcall my Set [list {*}$current {*}$args]\n"
-"\t\t}\n"
-"\t\tmethod -appendifnew -export args {\n"
-"\t\t\tset my [namespace which my]\n"
-"\t\t\tset current [uplevel 1 [list $my Get]]\n"
-"\t\t\tforeach a $args {\n"
-"\t\t\t\tset a [uplevel 1 [list $my Resolve $a]]\n"
-"\t\t\t\tif {$a ni $current} {\n"
-"\t\t\t\t\tlappend current $a\n"
-"\t\t\t\t}\n"
-"\t\t\t}\n"
-"\t\t\ttailcall my Set $current\n"
-"\t\t}\n"
-"\t\tmethod -clear -export {} {tailcall my Set {}}\n"
-"\t\tmethod -prepend -export args {\n"
-"\t\t\tset my [namespace which my]\n"
-"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
-"\t\t\tset current [uplevel 1 [list $my Get]]\n"
-"\t\t\ttailcall my Set [list {*}$args {*}$current]\n"
-"\t\t}\n"
-"\t\tmethod -remove -export args {\n"
-"\t\t\tset my [namespace which my]\n"
-"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
-"\t\t\tset current [uplevel 1 [list $my Get]]\n"
-"\t\t\ttailcall my Set [lmap val $current {\n"
-"\t\t\t\tif {$val in $args} continue else {set val}\n"
-"\t\t\t}]\n"
-"\t\t}\n"
-"\t\tforward --default-operation my -append\n"
-"\t\tmethod unknown -unexport {args} {\n"
-"\t\t\tset def --default-operation\n"
-"\t\t\tif {[llength $args] == 0} {\n"
-"\t\t\t\ttailcall my $def\n"
-"\t\t\t} elseif {![string match -* [lindex $args 0]]} {\n"
-"\t\t\t\ttailcall my $def {*}$args\n"
-"\t\t\t}\n"
-"\t\t\tnext {*}$args\n"
-"\t\t}\n"
-"\t\tunexport destroy\n"
-"\t}\n"
-"\tobjdefine define::superclass forward --default-operation my -set\n"
-"\tobjdefine define::mixin forward --default-operation my -set\n"
-"\tobjdefine objdefine::mixin forward --default-operation my -set\n"
 "\tdefine object method <cloned> -unexport {originObject} {\n"
 "\t\tforeach p [info procs [info object namespace $originObject]::*] {\n"
 "\t\t\tset args [info args $p]\n"
@@ -206,34 +55,44 @@ static const char *tclOOSetupScript =
 "\t\t}\n"
 "\t}\n"
 "\tdefine class method <cloned> -unexport {originObject} {\n"
+"\t\tset targetObject [self]\n"
 "\t\tnext $originObject\n"
-"\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n"
+"\t\tset originDelegate [::oo::DelegateName $originObject]\n"
+"\t\tset targetDelegate [::oo::DelegateName $targetObject]\n"
+"\t\tif {\n"
+"\t\t\t[info object isa class $originDelegate]\n"
+"\t\t\t&& ![info object isa class $targetDelegate]\n"
+"\t\t} then {\n"
+"\t\t\t::oo::copy $originDelegate $targetDelegate\n"
+"\t\t\t::oo::objdefine $targetObject mixin -set \\\n"
+"\t\t\t\t{*}[lmap c [info object mixin $targetObject] {\n"
+"\t\t\t\t\tif {$c eq $originDelegate} {set targetDelegate} {set c}\n"
+"\t\t\t\t}]\n"
+"\t\t}\n"
 "\t}\n"
-"\tclass create singleton {\n"
-"\t\tsuperclass -set class\n"
-"\t\tvariable -set object\n"
-"\t\tunexport create createWithNamespace\n"
-"\t\tmethod new args {\n"
-"\t\t\tif {![info exists object] || ![info object isa object $object]} {\n"
-"\t\t\t\tset object [next {*}$args]\n"
-"\t\t\t\t::oo::objdefine $object {\n"
-"\t\t\t\t\tmethod destroy {} {\n"
-"\t\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n"
-"\t\t\t\t\t\t\t\"may not destroy a singleton object\"\n"
-"\t\t\t\t\t}\n"
-"\t\t\t\t\tmethod <cloned> -unexport {originObject} {\n"
-"\t\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n"
-"\t\t\t\t\t\t\t\"may not clone a singleton object\"\n"
-"\t\t\t\t\t}\n"
-"\t\t\t\t}\n"
-"\t\t\t}\n"
-"\t\t\treturn $object\n"
+"\tclass create singleton\n"
+"\tdefine singleton superclass -set class\n"
+"\tdefine singleton unexport create createWithNamespace\n"
+"\tdefine singleton method new args {\n"
+"\t\tvariable object\n"
+"\t\tif {![info exists object] || ![info object isa object $object]} {\n"
+"\t\t\tset object [next {*}$args]\n"
+"\t\t\t::oo::objdefine $object mixin -prepend ::oo::SingletonInstance\n"
 "\t\t}\n"
+"\t\treturn $object\n"
 "\t}\n"
-"\tclass create abstract {\n"
-"\t\tsuperclass -set class\n"
-"\t\tunexport create createWithNamespace new\n"
+"\tclass create SingletonInstance\n"
+"\tdefine SingletonInstance method destroy {} {\n"
+"\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n"
+"\t\t\t\"may not destroy a singleton object\"\n"
 "\t}\n"
+"\tdefine SingletonInstance method <cloned> -unexport {originObject} {\n"
+"\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n"
+"\t\t\t\"may not clone a singleton object\"\n"
+"\t}\n"
+"\tclass create abstract\n"
+"\tdefine abstract superclass -set class\n"
+"\tdefine abstract unexport create createWithNamespace new\n"
 "\tnamespace eval configuresupport::configurableclass {\n"
 "\t\t::proc properties args {::tailcall property {*}$args}\n"
 "\t\t::namespace path ::oo::define\n"
@@ -248,14 +107,13 @@ static const char *tclOOSetupScript =
 "\t\tdefinitionnamespace -instance configuresupport::configurableobject\n"
 "\t\tdefinitionnamespace -class configuresupport::configurableclass\n"
 "\t}\n"
-"\tclass create configurable {\n"
-"\t\tsuperclass -set class\n"
-"\t\tconstructor {{definitionScript \"\"}} {\n"
-"\t\t\tnext {mixin ::oo::configuresupport::configurable}\n"
-"\t\t\tnext $definitionScript\n"
-"\t\t}\n"
-"\t\tdefinitionnamespace -class configuresupport::configurableclass\n"
+"\tclass create configurable\n"
+"\tdefine configurable superclass -set class\n"
+"\tdefine configurable constructor {{definitionScript \"\"}} {\n"
+"\t\t::oo::define [self] {mixin -append ::oo::configuresupport::configurable}\n"
+"\t\tnext $definitionScript\n"
 "\t}\n"
+"\tdefine configurable definitionnamespace -class configuresupport::configurableclass\n"
 "}\n"
 /* !END!: Do not edit above this line. */
 ;