TclOO appears to be a fairly bare-bones OO system, but there are many thing that it can do with just a little bit of scripting. Here are a few...
oo::class create foo {
self export varname
constructor {} {my eval upvar [[self class] varname v] v}
method bar {} {variable v; incr v}
}Demoing it...
% foo create x ::x % x bar 1 % x bar 2 % foo create y ::y % y bar 3
TJE: Here's the same, re-factored as a mixin for easier re-use. Using "my static" instead of "my variable" inside any method exposes the named static variable(s).
oo::class create Static {
method static {args} {
if {![llength $args]} return
set callclass [lindex [self caller] 0]
define $callclass self export varname
foreach vname $args {
lappend pairs [$callclass varname $vname] $vname
}
uplevel 1 upvar {*}$pairs
}
}Demoing it...
oo::class create Foo {
mixin Static
variable _inst_num
constructor {} {
my static _max_inst_num
set _inst_num [incr _max_inst_num]
}
method inst {} {
return $_inst_num
}
}
% [Foo new] inst
1
% [Foo new] inst
2DKF: Here's how to do it by leveraging the scripted guts of TclOO (from my Tcl2k9 paper):
proc ::oo::Helpers::classvar {name args} {
# Get reference to class’s namespace
set ns [info object namespace [uplevel 1 {self class}]]
# Double up the list of varnames
set vs [list $name $name]
foreach v $args {lappend vs $v $v}
# Link the caller’s locals to the
# class’s variables
tailcall namespace upvar $ns {*}$vs
}Demonstrating:
% oo::class create Foo {
method bar {z} {
classvar x y
return [incr x $z],[incr y]
}
}
::Foo
% Foo create a
::a
% Foo create b
::b
% a bar 2
2,1
% a bar 3
5,2
% b bar 7
12,3
% b bar -1
11,4
% a bar 0
11,5If you don't have tailcall, use this instead inside the definition:
uplevel 1 [list namespace upvar $ns {*}$ns]proc ::oo::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 == 4} {
uplevel 1 [list self method $name $args $body]
} elseif {$argc == 3} {
return -code error "wrong # args: should be \"[lindex [info level 0] 0] name ?args body?\""
}
# Get the name of the current class
set cls [lindex [info level -1] 1]
# Get its private “my” command
set my [info object namespace $cls]::my
# Make the connection by forwarding
tailcall forward $name $my $name
}Usage:
oo::class create Foo {
classmethod boo {x} {
puts "This is [self]::boo with argument x=$x"
}
}
Foo create bar
bar boo 42
# --> This is ::Foo::boo with argument x=42
Foo boo 7
# --> This is ::Foo::boo with argument x=7If you don't have tailcall, use this instead inside the definition:
uplevel 1 [list forward $name $my $name]
dzach: So, if I get it correctly, to create a class (static) method as shown above, one creates the method on the object of the class (i.e. an object method) and then creates a forward to it (i.e. a class forward), which (class forward) is then accessible by the class instances. Maybe the first comment line should read "# create the method on the class object if"
oo::class create singleton {
superclass oo::class
variable object
method create {name args} {
if {![info exists object]} {
set object [next $name {*}$args]
}
return $object
}
method new args {
if {![info exists object]} {
set object [next {*}$args]
}
return $object
}
}Demoing...
% oo::class create example {
self mixin singleton
method foo {} {self}
}
::example
% [example new] foo
::oo::Obj22
% [example new] foo
::oo::Obj22FF: I ended up in this solution for having private working both inside oo::class create xxx and in oo::define xxx {..}.
proc oo::define::private {what methodName argList body} {
set fn [info frame]
while {$fn > 0} {
set cmd [dict get [info frame $fn] cmd]
switch -- [lindex $cmd 0] {
oo::define { set c [lindex $cmd 1]; set fn 0 }
oo::class { set c [lindex $cmd 2]; set fn 0 }
}
incr fn -1
}
::oo::define $c [list $what $methodName $argList $body]
::oo::define $c [list unexport $methodName]
}oo::objdefine oo::class method private {method methodName argList body} {
if {$method != "method"} {return -code error "must be: private method <name> <args> <body>"}
my method $methodName $argList $body
my unexport $methodName
}
oo::class create test {
private method foo {} {puts "foo"}
method bar {} {puts "bar"; my foo}
}but doesn't work (invalid command name "private"). why?
DKF: This isn't documented (or supported, so liable to change without warning: caveat emptor) but you do this by creating commands in the namespace ‘::oo::define’ and ‘::oo::objdefine’. For example:
proc oo::define::private {method methodName argList body} {
if {$method ne "method"} {return -code error "must be: private method <name> <args> <body>"}
uplevel 1 [list method $methodName $argList $body]
uplevel 1 [list unexport $methodName]
}Much of TclOO's internal workings are really just simple reusing of existing Tcl things, but with interesting twists.
FF I tried it with Tcl-8.5 and TclOO-0.6 but get this error:
this command may only be called from within the context of an ::oo::define or ::oo::objdefine command
while executing
"method $methodName $argList $body"
(procedure "private" line 3)It seems proc oo::define::private {} {..} doesn't know the context (that is: the classname) the function gets called
DKF: Oops, forgot that. Adjusted to add uplevels where needed...
FF: This method does not seem to work. Try the previous one in case.
DKF: Turns out there was a bug (fixed in the HEAD of Tcl and TclOO-standalone) where it was looking for the context object in the wrong location.
DKF: … or how to let one object invoke private methods on another …
# This is a normal class except for the accessor method.
oo::class create foo {
variable x
constructor {} {
set x 1
}
method next {} {
incr x
puts $x
}
method BOOM {} {puts "Boom boom!"}
method accessor {} {namespace which my}
}
# This class will make use of the accessor method to connect
oo::class create bar {
variable y
constructor {other} {
# Allow access to other object's private methods through the local 'other' command
interp alias {} [self namespace]::other {} [$other accessor]
# Allow access to other object's variables, now we have the accessor mapped
my eval [list upvar 0 [other varname x] y]
}
forward boom other BOOM
method reset {} {
set y 0
puts resetting...
}
}
# Make the instances...
foo create fooInstance
bar create barInstance fooInstance
# Call a private method indirectly
barInstance boom
# Demonstrate that there is a single shared variable
fooInstance next
fooInstance next
barInstance reset
fooInstance next(Requires the CVS HEAD as I write this in order to fix a bug with forward resolution scope...)
The above prints this, with no errors:
Boom boom! 2 3 resetting... 1
DKF: You can script in a nicer way of declaring variables:
proc oo::define::Variable args {
set currentclass [lindex [info level 1] 1]
set existing [uplevel 1 [list info class variables $currentclass]]
switch [lindex $args 0] {
-append {
set vars $existing
lappend vars {*}[lrange $args 1 end]
}
-prepend {
set vars [lrange $args 1 end]
lappend vars {*}$existing
}
-remove {
set vars $existing
foreach var [lrange $args 1 end] {
set idx [lsearch -exact $vars $var]
if {$idx >= 0} {
set vars [lreplace $vars $idx $idx]
}
}
}
-set - default {
set vars [lrange $args 1 end]
}
}
uplevel 1 [list variables {*}$vars]
return
}Which then lets you do this:
oo::class create foo {
Variable x y
Variable -append p d q
method bar args {
lassign $args x y p d q
}
method boo {} {
return $x,$y|$p,$d,$q
}
}Note that this only works reliably for class declarations. (Well, that's all it works for syntactically anyway, but the obvious adaptations don't work reliably.) This is because of self declarations; there really ought to be a better mechanism for determining the current class or object in a declaration context...
From Rosetta Code :
package require Tcl 8.6
oo::class create Pool {
superclass oo::class
variable capacity pool busy
unexport create
constructor args {
next {*}$args
set capacity 100
set pool [set busy {}]
}
method new {args} {
if {[llength $pool]} {
set pool [lassign $pool obj]
} else {
if {[llength $busy] >= $capacity} {
throw {POOL CAPACITY} "exceeded capacity: $capacity"
}
set obj [next]
set newobj [namespace current]::[namespace tail $obj]
rename $obj $newobj
set obj $newobj
}
try {
[info object namespace $obj]::my Init {*}$args
} on error {msg opt} {
lappend pool $obj
return -options $opt $msg
}
lappend busy $obj
return $obj
}
method ReturnToPool obj {
try {
if {"Finalize" in [info object methods $obj -all -private]} {
[info object namespace $obj]::my Finalize
}
} on error {msg opt} {
after 0 [list return -options $opt $msg]
return false
}
set idx [lsearch -exact $busy $obj]
set busy [lreplace $busy $idx $idx]
if {[llength $pool] + [llength $busy] + 1 <= $capacity} {
lappend pool $obj
return true
} else {
return false
}
}
method capacity {{value {}}} {
if {[llength [info level 0]] == 3} {
if {$value < $capacity} {
while {[llength $pool] > 0 && [llength $pool] + [llength $busy] > $value} {
set pool [lassign $pool obj]
rename $obj {}
}
}
set capacity [expr {$value >> 0}]
} else {
return $capacity
}
}
method clearPool {} {
foreach obj $busy {
$obj destroy
}
}
method destroy {} {
my clearPool
next
}
self method create {class {definition {}}} {
set cls [next $class $definition]
oo::define $cls method destroy {} {
if {![[info object namespace [self class]]::my ReturnToPool [self]]} {
next
}
}
return $cls
}
}It's nice to use a private method for callbacks (for fileevent, trace, bind, etc.) This makes that easier:
proc ::oo::Helpers::callback {method args} {
list [uplevel 1 {namespace which my}] $method {*}$args
}Usage:
oo::class create CopyToStdout {
variable f
constructor {fd} {
set f $fd
fileevent $fd readable [callback Readable]
}
method Readable {} {
if {[gets $f line] >= 0} {
puts $line
} else {
my destroy
}
}
destructor {
close $f
}
}
new CopyToStdout [socket example.com 12345]mpdanielson: Borrowing from classmethod above, this proc creates ensemble methods that almost act like real methods. "self" and "my" don't work, but uplevel can be used to get back into the calling object's context.
proc ::oo::define::ensemble { name argList bodyScript } {
if { [llength $name] == 1 } {
tailcall method $name $argList $bodyScript
}
set cls [info object namespace [lindex [info level -1] 1]]
set ns ${cls}::[join [lrange $name 0 end-1] ::]
set cmd [lindex $name end]
namespace eval $ns [list proc $cmd $argList $bodyScript]
for {set i 1} {$i<[llength $name]} {incr i} {
namespace eval $ns [list namespace export $cmd]
namespace eval $ns {namespace ensemble create}
set cmd [namespace tail $ns]
set ns [namespace qualifiers $ns]
}
set entry [lindex $name 0]
tailcall method $entry { args } [format {
return [namespace eval %s [list %s {*}$args]]
} $cls $entry]
} ;# proc ::oo::define::ensembleUsage:
oo::class create Test {
ensemble {e0 add} { a b } {
return "$a + $b = [expr {$a + $b}]"
}
ensemble {e0 mul} { a b } {
return "$a * $b = [expr {$a * $b}]"
}
ensemble {e0 caller} {} {
return "called from [uplevel 2 self]"
}
ensemble {e0 x mod} {a b} {
return "$a % $b = [expr {$a % $b}]"
}
ensemble {e1 sub} { a b } {
return "$a - $b = [expr {$a - $b}]"
}
ensemble {e1 div} { a b } {
return "$a / $b = [expr {$a / $b}]"
}
ensemble m0 {} {
return "plain method"
}
} ;# class Test
(menu) 1 % Test create t
::t
(menu) 2 % t e0 add 3 4
3 + 4 = 7
(menu) 3 % t e0 caller
called from ::t
(menu) 4 % t e0 x mod 7 3
7 % 3 = 1