diff options
Diffstat (limited to 'generic/tclOOScript.tcl')
| -rw-r--r-- | generic/tclOOScript.tcl | 188 |
1 files changed, 122 insertions, 66 deletions
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 { |