summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclOOScript.h416
-rw-r--r--generic/tclOOScript.tcl447
-rw-r--r--tests/ooUtil.test39
-rw-r--r--tools/makeHeader.tcl22
4 files changed, 572 insertions, 352 deletions
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index d89e81a..741a5c4 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -22,225 +22,205 @@
static const char *tclOOSetupScript =
/* !BEGIN!: Do not edit below this line. */
-"::namespace eval ::oo::Helpers {\n"
-" ::namespace path {}\n"
-"\n"
-" proc callback {method args} {\n"
-" list [uplevel 1 {::namespace which my}] $method {*}$args\n"
-" }\n"
-"\n"
-" proc mymethod {method args} {\n"
-" list [uplevel 1 {::namespace which my}] $method {*}$args\n"
-" }\n"
-"\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"
-" # Lastly, link the caller\'s local variables to the class\'s variables\n"
-" tailcall namespace upvar $ns {*}$vs\n"
-" }\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"
"::namespace eval ::oo {\n"
-" proc UnlinkLinkedCommand {cmd args} {\n"
-" if {[namespace which $cmd] ne {}} {\n"
-" rename $cmd {}\n"
-" }\n"
-" }\n"
-"\n"
-" proc DelegateName {class} {\n"
-" string cat [info object namespace $class] {:: oo ::delegate}\n"
-" }\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"
-"\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"
-" }\n"
-"}\n"
-"\n"
-"::namespace eval ::oo::define {\n"
-" ::proc classmethod {name {args {}} {body {}}} {\n"
-" # 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 [::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"
-" ::oo::define [::oo::DelegateName $cls] method $name $args $body\n"
-" }\n"
-" # Make the connection by forwarding\n"
-" ::tailcall forward $name myclass $name\n"
-" }\n"
-"\n"
-" ::proc initialise {body} {\n"
-" ::set clsns [::info object namespace [::uplevel 1 self]]\n"
-" ::tailcall apply [::list {} $body $clsns]\n"
-" }\n"
-"\n"
-" # Make the initialise command appear with US spelling too\n"
-" ::namespace export initialise\n"
-" ::namespace eval tmp {::namespace import ::oo::define::initialise}\n"
-" ::rename ::oo::define::tmp::initialise initialize\n"
-" ::namespace delete tmp\n"
-" ::namespace export -clear\n"
-"}\n"
-"\n"
-"::oo::define ::oo::Slot {\n"
-" method Get {} {return -code error unimplemented}\n"
-" method Set list {return -code error unimplemented}\n"
-"\n"
-" method -set args {tailcall my Set $args}\n"
-" method -append args {\n"
-" set current [uplevel 1 [list [namespace which my] Get]]\n"
-" tailcall my Set [list {*}$current {*}$args]\n"
-" }\n"
-" method -clear {} {tailcall my Set {}}\n"
-" forward --default-operation my -append\n"
-"\n"
-" method unknown {args} {\n"
-" set def --default-operation\n"
-" if {[llength $args] == 0} {\n"
-" tailcall my $def\n"
-" } elseif {![string match -* [lindex $args 0]]} {\n"
-" tailcall my $def {*}$args\n"
-" }\n"
-" next {*}$args\n"
-" }\n"
-"\n"
-" export -set -append -clear\n"
-" unexport unknown destroy\n"
-"}\n"
-"\n"
-"::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n"
-"::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"
-" ::oo::UpdateClassDelegatesAfterClone $originObject [self]\n"
-"}\n"
-"\n"
-"::oo::class create ::oo::singleton {\n"
-" superclass ::oo::class\n"
-" variable object\n"
-" unexport create createWithNamespace\n"
-" method new args {\n"
-" if {![info exists object] || ![info object isa object $object]} {\n"
-" set object [next {*}$args]\n"
-" ::oo::objdefine $object method destroy {} {\n"
-" return -code error {may not destroy a singleton object}\n"
-" }\n"
-" ::oo::objdefine $object method <cloned> {originObject} {\n"
-" return -code error {may not clone a singleton object}\n"
-" }\n"
-" }\n"
-" return $object\n"
-" }\n"
-"}\n"
-"\n"
-"::oo::class create ::oo::abstract {\n"
-" superclass ::oo::class\n"
-" unexport create createWithNamespace new\n"
+"\t::namespace path {}\n"
+"\tnamespace eval Helpers {\n"
+"\t\t::namespace path {}\n"
+"\t\tproc callback {method args} {\n"
+"\t\t\tlist [uplevel 1 {::namespace which my}] $method {*}$args\n"
+"\t\t}\n"
+"\t\tnamespace export callback\n"
+"\t\tnamespace eval tmp {namespace import ::oo::Helpers::callback}\n"
+"\t\tnamespace export -clear\n"
+"\t\trename tmp::callback mymethod\n"
+"\t\tnamespace delete tmp\n"
+"\t\tproc classvariable {name args} {\n"
+"\t\t\tset ns [info object namespace [uplevel 1 {self class}]]\n"
+"\t\t\tforeach v [list $name {*}$args] {\n"
+"\t\t\t\tif {[string match *(*) $v]} {\n"
+"\t\t\t\t\tset reason \"can\'t create a scalar variable that looks like an array element\"\n"
+"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \\\n"
+"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n"
+"\t\t\t\t}\n"
+"\t\t\t\tif {[string match *::* $v]} {\n"
+"\t\t\t\t\tset reason \"can\'t create a local variable with a namespace separator in it\"\n"
+"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR INVERTED} \\\n"
+"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n"
+"\t\t\t\t}\n"
+"\t\t\t\tlappend vs $v $v\n"
+"\t\t\t}\n"
+"\t\t\ttailcall namespace upvar $ns {*}$vs\n"
+"\t\t}\n"
+"\t\tproc link {args} {\n"
+"\t\t\tset ns [uplevel 1 {::namespace current}]\n"
+"\t\t\tforeach link $args {\n"
+"\t\t\t\tif {[llength $link] == 2} {\n"
+"\t\t\t\t\tlassign $link src dst\n"
+"\t\t\t\t} elseif {[llength $link] == 1} {\n"
+"\t\t\t\t\tlassign $link src\n"
+"\t\t\t\t\tset dst $src\n"
+"\t\t\t\t} else {\n"
+"\t\t\t\t\treturn -code error -errorcode {TCLOO CMDLINK FORMAT} \\\n"
+"\t\t\t\t\t\t\"bad link description; must only have one or two elements\"\n"
+"\t\t\t\t}\n"
+"\t\t\t\tif {![string match ::* $src]} {\n"
+"\t\t\t\t\tset src [string cat $ns :: $src]\n"
+"\t\t\t\t}\n"
+"\t\t\t\tinterp alias {} $src {} ${ns}::my $dst\n"
+"\t\t\t\ttrace add command ${ns}::my delete [list \\\n"
+"\t\t\t\t\t::oo::UnlinkLinkedCommand $src]\n"
+"\t\t\t}\n"
+"\t\t\treturn\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 superclass -append $d\n"
+"\t\t}\n"
+"\t\tobjdefine $class mixin -append $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 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 {}} {body {}}} {\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 $body\n"
+"\t\t}\n"
+"\t\t::tailcall forward $name myclass $name\n"
+"\t}\n"
+"\tproc define::initialise {body} {\n"
+"\t\t::set clsns [::info object namespace [::uplevel 1 self]]\n"
+"\t\t::tailcall apply [::list {} $body $clsns]\n"
+"\t}\n"
+"\tnamespace eval define {\n"
+"\t\t::namespace export initialise\n"
+"\t\t::namespace eval tmp {::namespace import ::oo::define::initialise}\n"
+"\t\t::namespace export -clear\n"
+"\t\t::rename tmp::initialise initialize\n"
+"\t\t::namespace delete tmp\n"
+"\t}\n"
+"\tdefine Slot {\n"
+"\t\tmethod Get {} {\n"
+"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
+"\t\t}\n"
+"\t\tmethod Set list {\n"
+"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
+"\t\t}\n"
+"\t\tmethod -set args {tailcall my Set $args}\n"
+"\t\tmethod -append args {\n"
+"\t\t\tset current [uplevel 1 [list [namespace which my] Get]]\n"
+"\t\t\ttailcall my Set [list {*}$current {*}$args]\n"
+"\t\t}\n"
+"\t\tmethod -clear {} {tailcall my Set {}}\n"
+"\t\tforward --default-operation my -append\n"
+"\t\tmethod unknown {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\texport -set -append -clear\n"
+"\t\tunexport unknown 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> {originObject} {\n"
+"\t\tforeach p [info procs [info object namespace $originObject]::*] {\n"
+"\t\t\tset args [info args $p]\n"
+"\t\t\tset idx -1\n"
+"\t\t\tforeach a $args {\n"
+"\t\t\t\tif {[info default $p $a d]} {\n"
+"\t\t\t\t\tlset args [incr idx] [list $a $d]\n"
+"\t\t\t\t} else {\n"
+"\t\t\t\t\tlset args [incr idx] [list $a]\n"
+"\t\t\t\t}\n"
+"\t\t\t}\n"
+"\t\t\tset b [info body $p]\n"
+"\t\t\tset p [namespace tail $p]\n"
+"\t\t\tproc $p $args $b\n"
+"\t\t}\n"
+"\t\tforeach v [info vars [info object namespace $originObject]::*] {\n"
+"\t\t\tupvar 0 $v vOrigin\n"
+"\t\t\tnamespace upvar [namespace current] [namespace tail $v] vNew\n"
+"\t\t\tif {[info exists vOrigin]} {\n"
+"\t\t\t\tif {[array exists vOrigin]} {\n"
+"\t\t\t\t\tarray set vNew [array get vOrigin]\n"
+"\t\t\t\t} else {\n"
+"\t\t\t\t\tset vNew $vOrigin\n"
+"\t\t\t\t}\n"
+"\t\t\t}\n"
+"\t\t}\n"
+"\t}\n"
+"\tdefine class method <cloned> {originObject} {\n"
+"\t\tnext $originObject\n"
+"\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n"
+"\t}\n"
+"\tclass create singleton {\n"
+"\t\tsuperclass class\n"
+"\t\tvariable 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 {TCLOO 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> {originObject} {\n"
+"\t\t\t\t\t\t::return -code error -errorcode {TCLOO 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"
+"\t\t}\n"
+"\t}\n"
+"\tclass create abstract {\n"
+"\t\tsuperclass class\n"
+"\t\tunexport create createWithNamespace new\n"
+"\t}\n"
"}\n"
/* !END!: Do not edit above this line. */
;
diff --git a/generic/tclOOScript.tcl b/generic/tclOOScript.tcl
index c0b4d1f..d3706ce 100644
--- a/generic/tclOOScript.tcl
+++ b/generic/tclOOScript.tcl
@@ -11,70 +11,135 @@
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
-::namespace eval ::oo::Helpers {
+::namespace eval ::oo {
::namespace path {}
- proc callback {method args} {
- list [uplevel 1 {::namespace which my}] $method {*}$args
- }
+ #
+ # Commands that are made available to objects by default.
+ #
+ namespace eval Helpers {
+ ::namespace path {}
- proc mymethod {method args} {
- list [uplevel 1 {::namespace which my}] $method {*}$args
- }
+ # ------------------------------------------------------------------
+ #
+ # callback, mymethod --
+ #
+ # Create a script prefix that calls a method on the current
+ # object. Same operation, two names.
+ #
+ # ------------------------------------------------------------------
- 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
+ proc callback {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 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
+ # Make the [callback] command appear as [mymethod] too.
+ namespace export callback
+ namespace eval tmp {namespace import ::oo::Helpers::callback}
+ namespace export -clear
+ rename tmp::callback mymethod
+ namespace delete tmp
+
+ # ------------------------------------------------------------------
+ #
+ # classvariable --
+ #
+ # Link to a variable in the class of the current object.
+ #
+ # ------------------------------------------------------------------
+
+ 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]} {
+ 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
}
- if {![string match ::* $src]} {
- set src [string cat $ns :: $src]
+ # 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 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 {TCLOO 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]
}
- interp alias {} $src {} ${ns}::my $dst
- trace add command ${ns}::my delete [list \
- ::oo::UnlinkLinkedCommand $src]
+ return
}
- return
}
-}
-::namespace eval ::oo {
+ # ----------------------------------------------------------------------
+ #
+ # 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
@@ -93,6 +158,15 @@
objdefine $class mixin -append $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]
@@ -108,14 +182,24 @@
}]
}
}
-}
-::namespace eval ::oo::define {
- ::proc classmethod {name {args {}} {body {}}} {
+ # ----------------------------------------------------------------------
+ #
+ # 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 {}} {body {}}} {
# 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 [::format \
+ ::return -code error -errorcode {TCL WRONGARGS} [::format \
{wrong # args: should be "%s name ?args body?"} \
[::lindex [::info level 0] 0]]
}
@@ -127,109 +211,208 @@
::tailcall forward $name myclass $name
}
- ::proc initialise {body} {
+ # ----------------------------------------------------------------------
+ #
+ # oo::define::initialise, oo::define::initialize --
+ #
+ # Do specific initialisation for a class. 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::initialise {body} {
::set clsns [::info object namespace [::uplevel 1 self]]
::tailcall apply [::list {} $body $clsns]
}
- # Make the initialise command appear with US spelling too
- ::namespace export initialise
- ::namespace eval tmp {::namespace import ::oo::define::initialise}
- ::rename ::oo::define::tmp::initialise initialize
- ::namespace delete tmp
- ::namespace export -clear
-}
+ # Make the [initialise] definition appear as [initialize] too
+ namespace eval define {
+ ::namespace export initialise
+ ::namespace eval tmp {::namespace import ::oo::define::initialise}
+ ::namespace export -clear
+ ::rename tmp::initialise initialize
+ ::namespace delete tmp
+ }
-::oo::define ::oo::Slot {
- method Get {} {return -code error unimplemented}
- method Set list {return -code error unimplemented}
+ # ----------------------------------------------------------------------
+ #
+ # Slot --
+ #
+ # The class of slot operations, which are basically lists at the low
+ # level of TclOO; this provides a more consistent interface to them.
+ #
+ # ----------------------------------------------------------------------
- method -set args {tailcall my Set $args}
- method -append args {
- set current [uplevel 1 [list [namespace which my] Get]]
- tailcall my Set [list {*}$current {*}$args]
- }
- method -clear {} {tailcall my Set {}}
- forward --default-operation my -append
-
- method unknown {args} {
- set def --default-operation
- if {[llength $args] == 0} {
- tailcall my $def
- } elseif {![string match -* [lindex $args 0]]} {
- tailcall my $def {*}$args
- }
- next {*}$args
- }
+ define Slot {
+ # ------------------------------------------------------------------
+ #
+ # Slot Get --
+ #
+ # Basic slot getter. Retrieves the contents of the slot.
+ # Particular slots must provide concrete non-erroring
+ # implementation.
+ #
+ # ------------------------------------------------------------------
- export -set -append -clear
- unexport unknown destroy
-}
+ method Get {} {
+ return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented"
+ }
-::oo::objdefine ::oo::define::superclass forward --default-operation my -set
-::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]
+ # ------------------------------------------------------------------
+ #
+ # Slot Set --
+ #
+ # Basic slot setter. Sets the contents of the slot. Particular
+ # slots must provide concrete non-erroring implementation.
+ #
+ # ------------------------------------------------------------------
+
+ method Set list {
+ return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented"
+ }
+
+ # ------------------------------------------------------------------
+ #
+ # 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 args {tailcall my Set $args}
+ method -append args {
+ set current [uplevel 1 [list [namespace which my] Get]]
+ tailcall my Set [list {*}$current {*}$args]
+ }
+ method -clear {} {tailcall my Set {}}
+
+ # Default handling
+ forward --default-operation my -append
+ method unknown {args} {
+ set def --default-operation
+ if {[llength $args] == 0} {
+ tailcall my $def
+ } elseif {![string match -* [lindex $args 0]]} {
+ tailcall my $def {*}$args
}
+ next {*}$args
}
- set b [info body $p]
- set p [namespace tail $p]
- proc $p $args $b
+
+ # Set up what is exported and what isn't
+ export -set -append -clear
+ unexport unknown destroy
}
- # 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
+
+ # 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> --
+ #
+ # Handler for cloning objects that clones basic bits (only!) of the
+ # object's namespace. Non-procedures, traces, sub-namespaces, etc. need
+ # more complex (and class-specific) handling.
+ #
+ # ----------------------------------------------------------------------
+
+ define 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.
}
- # 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
- ::oo::UpdateClassDelegatesAfterClone $originObject [self]
-}
+ # ----------------------------------------------------------------------
+ #
+ # oo::class <cloned> --
+ #
+ # Handler for cloning classes, which fixes up the delegates.
+ #
+ # ----------------------------------------------------------------------
-::oo::class create ::oo::singleton {
- superclass ::oo::class
- variable 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 {may not destroy a singleton object}
- }
- ::oo::objdefine $object method <cloned> {originObject} {
- return -code error {may not clone a singleton object}
- }
- }
- return $object
+ define class method <cloned> {originObject} {
+ next $originObject
+ # Rebuild the class inheritance delegation class
+ ::oo::UpdateClassDelegatesAfterClone $originObject [self]
}
-}
-::oo::class create ::oo::abstract {
- superclass ::oo::class
- unexport create createWithNamespace new
+ # ----------------------------------------------------------------------
+ #
+ # oo::singleton --
+ #
+ # A metaclass that is used to make classes that only permit one instance
+ # of them to exist. See singleton(n).
+ #
+ # ----------------------------------------------------------------------
+
+ class create singleton {
+ superclass class
+ variable 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 {TCLOO SINGLETON} \
+ "may not destroy a singleton object"
+ }
+ method <cloned> {originObject} {
+ ::return -code error -errorcode {TCLOO SINGLETON} \
+ "may not clone a singleton object"
+ }
+ }
+ }
+ return $object
+ }
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # oo::abstract --
+ #
+ # A metaclass that is used to make classes that can't be directly
+ # instantiated. See abstract(n).
+ #
+ # ----------------------------------------------------------------------
+
+ class create abstract {
+ superclass class
+ unexport create createWithNamespace new
+ }
}
# Local Variables:
diff --git a/tests/ooUtil.test b/tests/ooUtil.test
index e796637..ff7093f 100644
--- a/tests/ooUtil.test
+++ b/tests/ooUtil.test
@@ -138,6 +138,45 @@ test ooUtil-1.7 {} -setup {
} -cleanup {
parent destroy
} -result {{} {} {} {}} -output "This is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\nThis is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\n"
+# Two tests to confirm that we correctly initialise the scripted part of TclOO
+# in child interpreters. This is slightly tricky at the implementation level
+# because we cannot count on either [source] or [open] being available.
+test ooUtil-1.8 {TIP 478: classmethod in child interp} -setup {
+ set childinterp [interp create]
+} -body {
+ $childinterp eval {
+ oo::class create ActiveRecord {
+ classmethod find args {
+ return "[self] called with arguments: $args"
+ }
+ }
+ oo::class create Table {
+ superclass ActiveRecord
+ }
+ # This is confirming that this is not the master interpreter
+ list [Table find foo bar] [info globals childinterp]
+ }
+} -cleanup {
+ interp delete $childinterp
+} -result {{::Table called with arguments: foo bar} {}}
+test ooUtil-1.9 {TIP 478: classmethod in safe child interp} -setup {
+ set safeinterp [interp create -safe]
+} -body {
+ $safeinterp eval {
+ oo::class create ActiveRecord {
+ classmethod find args {
+ return "[self] called with arguments: $args"
+ }
+ }
+ oo::class create Table {
+ superclass ActiveRecord
+ }
+ # This is confirming that this is a (basic) safe interpreter
+ list [Table find foo bar] [info commands source]
+ }
+} -cleanup {
+ interp delete $safeinterp
+} -result {{::Table called with arguments: foo bar} {}}
test ooUtil-2.1 {TIP 478: callback generation} -setup {
oo::class create parent
diff --git a/tools/makeHeader.tcl b/tools/makeHeader.tcl
index 5197da6..e9b7ed1 100644
--- a/tools/makeHeader.tcl
+++ b/tools/makeHeader.tcl
@@ -21,7 +21,7 @@ namespace eval makeHeader {
# All Tcl metacharacters and key C backslash sequences
set MAP {
\" \\\\\" \\ \\\\\\\\ $ \\$ [ \\[ ] \\] ' \\\\' ? \\\\?
- \a \\\\a \b \\\\b \f \\\\f \n \\\\n \r \\\\r \t { } \v \\\\v
+ \a \\\\a \b \\\\b \f \\\\f \n \\\\n \r \\\\r \t \\\\t \v \\\\v
}
set XFORM {[format \\\\\\\\u%04x {*}[scan & %c]]}
@@ -30,12 +30,30 @@ namespace eval makeHeader {
####################################################################
#
+ # compactLeadingSpaces --
+ # Converts the leading whitespace on a line into a more compact form.
+ #
+ proc compactLeadingSpaces {line} {
+ set line [string map {\t { }} [string trimright $line]]
+ if {[regexp {^[ ]+} $line spaces]} {
+ regsub -all {[ ]{4}} $spaces \t replace
+ set len [expr {[string length $spaces] - 1}]
+ set line [string replace $line 0 $len $replace]
+ }
+ return $line
+ }
+
+ ####################################################################
+ #
# processScript --
# Transform a whole sequence of lines with [mapSpecial].
#
proc processScript {scriptLines} {
lmap line $scriptLines {
- format {"%s"} [mapSpecial $line\n]
+ # Skip blank and comment lines; they're there in the original
+ # sources so we don't need to copy them over.
+ if {[regexp {^\s*(?:#|$)} $line]} continue
+ format {"%s"} [mapSpecial [compactLeadingSpaces $line]\n]
}
}
generated by cgit v0.12 at 2025-12-04 08:42:15 (GMT)