Merge trunk

1 files changed, 51 insertions, 326 deletions

diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
index 542b711..b17d7d0 100644
--- a/tools/tclOOScript.tcl
+++ b/tools/tclOOScript.tcl
@@ -12,299 +12,6 @@
 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
 
 ::namespace eval ::oo {
-
-    #
-    # Commands that are made available to objects by default.
-    #
-
-    # ------------------------------------------------------------------
-    #
-    # classvariable --
-    #
-    #	Link to a variable in the class of the current object.
-    #
-    # ------------------------------------------------------------------
-
-    proc 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]} {
-		set reason "can't create a scalar variable that looks like an array element"
-		return -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \
-		    [format {bad variable name "%s": %s} $v $reason]
-	    }
-	    if {[string match *::* $v]} {
-		set reason "can't create a local variable with a namespace separator in it"
-		return -code error -errorcode {TCL UPVAR INVERTED} \
-		    [format {bad variable name "%s": %s} $v $reason]
-	    }
-	    lappend vs $v $v
-	}
-	# Lastly, link the caller's local variables to the class's variables
-	tailcall namespace upvar $ns {*}$vs
-    }
-
-    # ------------------------------------------------------------------
-    #
-    # link --
-    #
-    #	Make a command that invokes a method on the current object.
-    #	The name of the command and the name of the method match by
-    #	default.
-    #
-    # ------------------------------------------------------------------
-
-    proc Helpers::link {args} {
-	set ns [uplevel 1 {::namespace current}]
-	foreach link $args {
-	    if {[llength $link] == 2} {
-		lassign $link src dst
-	    } elseif {[llength $link] == 1} {
-		lassign $link src
-		set dst $src
-	    } else {
-		return -code error -errorcode {TCL OO CMDLINK_FORMAT} \
-		    "bad link description; must only have one or two elements"
-	    }
-	    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]
-	}
-    }
-
-    # ----------------------------------------------------------------------
-    #
-    # UnlinkLinkedCommand --
-    #
-    #	Callback used to remove linked command when the underlying mechanism
-    #	that supports it is deleted.
-    #
-    # ----------------------------------------------------------------------
-
-    proc UnlinkLinkedCommand {cmd args} {
-	if {[namespace which $cmd] ne {}} {
-	    rename $cmd {}
-	}
-    }
-
-    # ----------------------------------------------------------------------
-    #
-    # DelegateName --
-    #
-    #	Utility that gets the name of the class delegate for a class. It's
-    #	trivial, but makes working with them much easier as delegate names are
-    #	intentionally hard to create by accident.
-    #
-    # ----------------------------------------------------------------------
-
-    proc DelegateName {class} {
-	string cat [info object namespace $class] {:: oo ::delegate}
-    }
-
-    # ----------------------------------------------------------------------
-    #
-    # MixinClassDelegates --
-    #
-    #	Support code called *after* [oo::define] inside the constructor of a
-    #	class that patches in the appropriate class delegates.
-    #
-    # ----------------------------------------------------------------------
-
-    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 ::oo::define::superclass -appendifnew $d
-	}
-	objdefine $class ::oo::objdefine::mixin -appendifnew $delegate
-    }
-
-    # ----------------------------------------------------------------------
-    #
-    # UpdateClassDelegatesAfterClone --
-    #
-    #	Support code that is like [MixinClassDelegates] except for when a
-    #	class is cloned.
-    #
-    # ----------------------------------------------------------------------
-
-    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 ::oo::objdefine::mixin -set \
-		{*}[lmap c [info object mixin $targetObject] {
-		    if {$c eq $originDelegate} {set targetDelegate} {set c}
-		}]
-	}
-    }
-
-    # ----------------------------------------------------------------------
-    #
-    # oo::define::classmethod --
-    #
-    #	Defines a class method. See define(n) for details.
-    #
-    # Note that the ::oo::define namespace is semi-public and a bit weird
-    # anyway, so we don't regard the namespace path as being under control:
-    # fully qualified names are used for everything.
-    #
-    # ----------------------------------------------------------------------
-
-    proc define::classmethod {name args} {
-	# 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 -errorcode {TCL WRONGARGS} [::format \
-		{wrong # args: should be "%s name ?args body?"} \
-		[::lindex [::info level 0] 0]]
-	}
-	::set cls [::uplevel 1 self]
-	::if {$argc == 4} {
-	    ::oo::define [::oo::DelegateName $cls] method $name {*}$args
-	}
-	# Make the connection by forwarding
-	::tailcall forward $name myclass $name
-    }
-
-    # ----------------------------------------------------------------------
-    #
-    # Slot --
-    #
-    #	The class of slot operations, which are basically lists at the low
-    #	level of TclOO; this provides a more consistent interface to them.
-    #
-    # ----------------------------------------------------------------------
-
-    define Slot {
-	# ------------------------------------------------------------------
-	#
-	# Slot Get --
-	#
-	#	Basic slot getter. Retrieves the contents of the slot.
-	#	Particular slots must provide concrete non-erroring
-	#	implementation.
-	#
-	# ------------------------------------------------------------------
-
-	method Get -unexport {} {
-	    return -code error -errorcode {TCL OO ABSTRACT_SLOT} "unimplemented"
-	}
-
-	# ------------------------------------------------------------------
-	#
-	# Slot Set --
-	#
-	#	Basic slot setter. Sets the contents of the slot.  Particular
-	#	slots must provide concrete non-erroring implementation.
-	#
-	# ------------------------------------------------------------------
-
-	method Set -unexport list {
-	    return -code error -errorcode {TCL OO ABSTRACT_SLOT} "unimplemented"
-	}
-
-	# ------------------------------------------------------------------
-	#
-	# Slot Resolve --
-	#
-	#	Helper that lets a slot convert a list of arguments of a
-	#	particular type to their canonical forms. Defaults to doing
-	#	nothing (suitable for simple strings).
-	#
-	# ------------------------------------------------------------------
-
-	method Resolve -unexport list {
-	    return $list
-	}
-
-	# ------------------------------------------------------------------
-	#
-	# Slot -set, -append, -clear, --default-operation --
-	#
-	#	Standard public slot operations. If a slot can't figure out
-	#	what method to call directly, it uses --default-operation.
-	#
-	# ------------------------------------------------------------------
-
-	method -set -export args {
-	    set my [namespace which my]
-	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
-	    tailcall my Set $args
-	}
-	method -append -export args {
-	    set my [namespace which my]
-	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
-	    set current [uplevel 1 [list $my Get]]
-	    tailcall my Set [list {*}$current {*}$args]
-	}
-	method -appendifnew -export args {
-	    set my [namespace which my]
-	    set current [uplevel 1 [list $my Get]]
-	    foreach a $args {
-		set a [uplevel 1 [list $my Resolve $a]]
-		if {$a ni $current} {
-		    lappend current $a
-		}
-	    }
-	    tailcall my Set $current
-	}
-	method -clear -export {} {tailcall my Set {}}
-	method -prepend -export args {
-	    set my [namespace which my]
-	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
-	    set current [uplevel 1 [list $my Get]]
-	    tailcall my Set [list {*}$args {*}$current]
-	}
-	method -remove -export args {
-	    set my [namespace which my]
-	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
-	    set current [uplevel 1 [list $my Get]]
-	    tailcall my Set [lmap val $current {
-		if {$val in $args} continue else {set val}
-	    }]
-	}
-
-	# Default handling
-	forward --default-operation my -append
-	method unknown -unexport {args} {
-	    set def --default-operation
-	    if {[llength $args] == 0} {
-		tailcall my $def
-	    } elseif {![string match -* [lindex $args 0]]} {
-		tailcall my $def {*}$args
-	    }
-	    next {*}$args
-	}
-
-	# Hide destroy
-	unexport destroy
-    }
-
-    # Set the default operation differently for these slots
-    objdefine define::superclass forward --default-operation my -set
-    objdefine define::mixin forward --default-operation my -set
-    objdefine objdefine::mixin forward --default-operation my -set
-
     # ----------------------------------------------------------------------
     #
     # oo::object <cloned> --
@@ -357,9 +64,21 @@
     # ----------------------------------------------------------------------
 
     define class method <cloned> -unexport {originObject} {
+	set targetObject [self]
 	next $originObject
 	# Rebuild the class inheritance delegation class
-	::oo::UpdateClassDelegatesAfterClone $originObject [self]
+	set originDelegate [::oo::DelegateName $originObject]
+	set targetDelegate [::oo::DelegateName $targetObject]
+	if {
+	    [info object isa class $originDelegate]
+	    && ![info object isa class $targetDelegate]
+	} then {
+	    ::oo::copy $originDelegate $targetDelegate
+	    ::oo::objdefine $targetObject mixin -set \
+		{*}[lmap c [info object mixin $targetObject] {
+		    if {$c eq $originDelegate} {set targetDelegate} {set c}
+		}]
+	}
     }
 
     # ----------------------------------------------------------------------
@@ -371,26 +90,35 @@
     #
     # ----------------------------------------------------------------------
 
-    class create singleton {
-	superclass -set class
-	variable -set object
-	unexport create createWithNamespace
-	method new args {
-	    if {![info exists object] || ![info object isa object $object]} {
-		set object [next {*}$args]
-		::oo::objdefine $object {
-		    method destroy {} {
-			::return -code error -errorcode {TCL OO SINGLETON} \
-			    "may not destroy a singleton object"
-		    }
-		    method <cloned> -unexport {originObject} {
-			::return -code error -errorcode {TCL OO SINGLETON} \
-			    "may not clone a singleton object"
-		    }
-		}
-	    }
-	    return $object
+    class create singleton
+    define singleton superclass -set class
+    define singleton unexport create createWithNamespace
+    define singleton method new args {
+	variable object
+	if {![info exists object] || ![info object isa object $object]} {
+	    set object [next {*}$args]
+	    ::oo::objdefine $object mixin -prepend ::oo::SingletonInstance
 	}
+	return $object
+    }
+
+    # ----------------------------------------------------------------------
+    #
+    # oo::SingletonInstance --
+    #
+    #	A mixin used to make an object so it won't be destroyed or cloned (or
+    #	at least not easily).
+    #
+    # ----------------------------------------------------------------------
+
+    class create SingletonInstance
+    define SingletonInstance method destroy {} {
+	return -code error -errorcode {TCL OO SINGLETON} \
+	    "may not destroy a singleton object"
+    }
+    define SingletonInstance method <cloned> -unexport {originObject} {
+	return -code error -errorcode {TCL OO SINGLETON} \
+	    "may not clone a singleton object"
     }
 
     # ----------------------------------------------------------------------
@@ -402,10 +130,9 @@
     #
     # ----------------------------------------------------------------------
 
-    class create abstract {
-	superclass -set class
-	unexport create createWithNamespace new
-    }
+    class create abstract
+    define abstract superclass -set class
+    define abstract unexport create createWithNamespace new
 
     # ----------------------------------------------------------------------
     #
@@ -485,16 +212,14 @@
     #
     # ----------------------------------------------------------------------
 
-    class create configurable {
-	superclass -set class
-
-	constructor {{definitionScript ""}} {
-	    next {mixin ::oo::configuresupport::configurable}
-	    next $definitionScript
-	}
-
-	definitionnamespace -class configuresupport::configurableclass
+    class create configurable
+    define configurable superclass -set class
+    define configurable constructor {{definitionScript ""}} {
+	::oo::define [self] {mixin -append ::oo::configuresupport::configurable}
+	next $definitionScript
     }
+
+    define configurable definitionnamespace -class configuresupport::configurableclass
 }
 
 # Local Variables: