diff options
Diffstat (limited to 'tools/tclOOScript.tcl')
| -rw-r--r-- | tools/tclOOScript.tcl | 377 |
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: |