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...
Several of these techniques are explored in an alternative style at Extending TclOO with metaclasses, which avoids some of the risks inherent in writing directly on oo::define. There is also some interesting related code in Aspect support class for TclOO.
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]
oo::objdefine $callclass 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"
DJS: This is *almost* what I was looking for. The one problem with this is that if there is a derived class that superclasses Foo the classmethod doesn't get added to the derived class. I'm trying to do something like Ruby on Rails ActiveRecord model where all you need for the derived class is the class declaration inheriting from ActiveRecord (http://api.rubyonrails.org/classes/ActiveRecord/Base.html )
oo::class create ActiveRecord {
classmethod find args { puts "[self] called with arguments: $args" }
}
oo::class create Table {
superclass ActiveRecord
}
Then be able to do:
Table find last
# --> ::ActiveRecord::find called with arguments: lastHow could that added behavior be added to create or superclass?
DKF: To do the job fully, it is necessary to introduce an additional relationship between the classes concerned (and to refine how class methods are created) in order to model the sort of structure that exists in the Ruby class system (it also exists in the Java class system, but it's use is frowned upon there). This is relatively easy to hide out of the way (though I'm not 100% sure that the way I do it below is correct):
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 == 3} {
return -code error "wrong # args: should be \"[lindex [info level 0] 0] name ?args body?\""
}
# Get the name of the current class or class delegate
set cls [namespace which [lindex [info level -1] 1]]
set d $cls.Delegate
if {[info object isa object $d] && [info object isa class $d]} {
set cls $d
}
if {$argc == 4} {
oo::define $cls method $name $args $body
}
# Make the connection by forwarding
uplevel 1 [list forward $name [info object namespace $cls]::my $name]
}
# Build this *almost* like a class method, but with extra care to avoid nuking
# the existing method.
oo::class create oo::class.Delegate {
method create {name {script ""}} {
if {[string match *.Delegate $name]} {
return [next $name $script]
}
set cls [next $name]
set delegate [oo::class create $cls.Delegate]
oo::define $cls $script
set superdelegates [list $delegate]
foreach c [info class superclass $cls] {
set d $c.Delegate
if {[info object isa object $d] && [info object isa class $d]} {
lappend superdelegates $d
}
}
oo::objdefine $cls mixin {*}$superdelegates
return $cls
}
}
oo::define oo::class self mixin oo::class.DelegateDemonstrating…
oo::class create ActiveRecord {
classmethod find args { puts "[self] called with arguments: $args" }
}
oo::class create Table {
superclass ActiveRecord
}
Table find foo barwhich will write this out (I tested it):
::Table called with arguments: foo bar
Twylite 2013-03-01: See 'Finding The Class You're Defining' below for a less fragile way to identify the current class.
aspect 2014-10-03: The above definition is dangerous, in that it forces the arguments of method create. This causes an obscure bug when loaded before another class definition with a different signature for create. It is my opinion that the version in Extending TclOO with Metaclasses is more correct (though it requires different usage) for two reasons: it doesn't exhibit this obscure bug, and it doesn't mess with core commands like oo::define, potentially conflicting with other packages. It also doesn't rely on Twylite's clever but fragile hack. Finally, I don't believe the above definition can be made robust against all variations of method create people might implement.
I'm not sure what would be the process to get tcllib's ooutil updated with the metaclass version: it doesn't feel quite mature enough to me that it should go in, though I question the inclusion of ooutil as it stands for the same reason. Another issue it that people are already reliant on ooutil, they will need to change their code to use an appropriate metaclass instead of oo::class.
ak 2014-10-03: It could go into a branch of Tcllib where it could be tested. Maybe also a (slightly) different name to distinguish the two. If we do a full-on replacement the difference in usage would force us to bump oo::util to v2, i.e. major version number change. As a general note it might be best to make a ticket for it, with the code attached.
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::Obj22gasty Using [example create obj] fails after the first time, since the "create" method doesn't link the name provided with the object command.
Maybe interp alias can be used for this:
method create {name args} {
if {![info exists object]} {
set object [next $name {*}$args]
} else {
interp alias {} $name {} $object
}
return $object
}Missing things:
aspect: what does a singleton want with a class and constructor? This isn't Java:
% oo::object create example
::example
% oo::objdefine example {
variable x
method foo {{i 1}} {
return "[self]: [incr x $i]"
}
unexport destroy
}
% example foo
::example: 1
% example foo 5
::example: 6
% pdict [inspect example] ;# see https://wiki.tcl-lang.org/40640
isa = object
object class = ::oo::object
object methods = foo
object methods -private = foo
object methods -all = foo
object variables = x
object namespace = ::oo::Obj23
object vars = x
object commands = my
object commands -private = my
object commands -all = myDKF: In many ways, you can do just fine by making a single named object; most of the sane uses of singletons come out as being effectively that.
FF: 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]
}Twylite 2013-03-01: See 'Finding The Class You're Defining' below for a less fragile way to identify the current class.
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...
manveru: The code above doesn't seem to work anymore, you can replace the uplevel command with:
::oo::define $currentclass variable {*}$varsDKF: With the trunk, (a more sophisticated version of) this is part of the baseline functionality.
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
fconfigure $fd -blocking 0
fileevent $fd readable [callback Readable]
}
method Readable {} {
if {[gets $f line] >= 0} {
puts $line
} elseif {[fblocked $file]} {
# do nothing
} else {
my destroy
}
}
destructor {
close $f
}
}
new CopyToStdout [socket example.com 12345]mpdanielson: Borrowing from classmethod above, this proc allows creation of ensemble methods with inheritance
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 cmd [lindex $name end]
set ns ${cls}::[join [lrange $name 0 end-1] ::]
if { $argList != {} } {
foreach a $argList {
append init [format {uplevel 2 [list set %1$s $%1$s]} $a]\n
}
set body [format {
%1$s
uplevel 2 {
try {
%2$s
} finally {
unset -nocomplain %3$s
}
}
} $init $bodyScript $argList]
} else {
set body "uplevel 2 [list $bodyScript]"
}
namespace eval $ns [list proc $cmd $argList $body]
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 {
if { ![catch {namespace eval %s [list %s {*}$args]} result erropts] } {
return $result
}
set pattern {^(unknown or ambiguous subcommand ".*": must be)(.*)}
if { [regexp $pattern $result -> prefix cmds] } {
if { [self next] != {} } {
if { [catch {next {*}$args} nextResult nextErropts] } {
if { [regexp $pattern $nextResult -> -> ncmds] } {
set all [lsort -dict -uniq [regsub -all {, |, or |or } "$cmds $ncmds" { }]]
set fmt [regsub {, ([[:graph:]]+)$} [join $all ", "] { or \1}]
return -code error "$prefix $fmt"
}
return -options $nextErropts $nextResult
}
return $nextResult
}
}
return -options $erropts $result
return [namespace eval %s [list %s {*}$args]]
} $cls $entry]
} ;# proc ::oo::define::ensembleUsage:
oo::class create Test {
ensemble {e add} { a b } {
return "$a + $b = [expr {$a + $b}]"
}
ensemble {e self} {} {
return "self is: [self]"
}
ensemble {e calladd} {a b} {
return [my e add $a $b]
}
ensemble {e x calladd} {a b} {
return [my e add $a $b]
}
ensemble {e x y self} {} {
return "self is: [self]"
}
ensemble m0 {} {
return "plain method"
}
} ;# class Test
oo::class create T2 {
superclass Test
ensemble {e mul} { a b } {
return "$a * $b = [expr {$a * $b}]"
}
}
oo::class create T3 {
superclass T2
ensemble {e add} { a b } {
return "$a + $b < [expr {$a + $b + 1}]"
}
ensemble {e div} { a b } {
return "$a / $b = [expr {$a / $b}]"
}
}
Test create t
T2 create t2
T3 create t3
(test) 1 % t e add 1 2
1 + 2 = 3
(test) 2 % t e self
self is: ::t
(test) 3 % t e calladd 2 3
2 + 3 = 5
(test) 4 % t e x calladd 3 4
3 + 4 = 7
(test) 5 % t e x y self
self is: ::t
(test) 6 % t2 e mul 6 7
6 * 7 = 42
(test) 7 % t2 e add 8 9
8 + 9 = 17
(test) 8 % t3 e add 10 11
10 + 11 < 22
(test) 9 % t3 e boo
unknown or ambiguous subcommand "boo": must be add, calladd, div, error, mul, self or x
From dkf's notes in the Tclers chat:
upvar [info object namespace [self class]]::var var
Notes:
proc classvar var {
set c [uplevel 1 self class]
tailcall namespace upvar [info object namespace $c] $var $var
}DKF: You can do a lot with scripting. Here's an example from some code I'm working on:
oo::class create example {
@Describe This is the foo method. It has multiple annotations \
attached to it.
@Argument x The first argument to the method.
@Argument args The list of remaining arguments to the method.
@Result None.
@SideEffects Prints to stdout.
method foo {x args} { puts foo }
@Describe This is the bar method.
method bar args { puts bar }
}
puts annotations:\t[info class annotation example]
puts desc-foo:\t[info class annotation example @Describe foo]
puts args-foo:\t[info class annotation example @Argument foo]
foreach a [info class annotation example @Argument foo] {
puts args-foo-${a}:\t[info class annotation example @Argument foo $a]
}
puts result-foo:\t[info class annotation example @Result foo]
puts effects-foo:\t[info class annotation example @SideEffects foo]Ever decided that the default handling of how you make subclasses just didn't quite do it for you? Try this!
oo::define oo::class {
method derive args {
# Argument parsing...
switch [llength $args] {
1 {
set sub [lindex $args 0]
set super [list [self]]
set def {}
}
2 {
lassign $args sub def
set super [list [self]]
}
3 {
lassign $args sub super def
set super [list [self] {*}$super]
}
default {
set cmd [lrange [info level -1] 0 end-[llength $args]]
lappend cmd subclass ?extraSuperclasses? ?definition?
return -code error "wrong # args: should be \"$cmd\""
}
}
# Make a "nice" subclass of this class
set sub [uplevel 1 [list oo::class create $sub $def]]
oo::define $sub superclass $super
oo::objdefine $sub class [info object class [self]]
return $sub
}
}Sample of use:
% oo::class create foo {superclass oo::class}
::foo
% foo derive bar
::bar
% info object class bar
::oo::class
% info class superclass bar
::foo
% foo create x
::x
% x derive y
::y
% info object class y
::foo
% info class superclass y
::xThis code is pretty bad, eh? Feel free to improve, and please replace!
oo::class create accessor-mixin {
method accessor {args} {
foreach param $args {
eval [string map "_PARAM_ $param" {
oo::define [info object class [self object]] method _PARAM_ {{value {}}} {
if {[llength [info level 0]] == 3} {set _PARAM_ $value}
return $_PARAM_
}
}]
}
}
}Sample of use:
oo::class create accessor-test {
mixin accessor-mixin
variable w y z
constructor {} {
[self] accessor w y z
}
}
set x [accessor-test new]
$x w 10
puts [$x w]
$x y 20
puts [$x y]
$x z 30
puts [$x z]jbr 2011-02-20 : Here is my cut at accessors:
I'm using the undocumented "oo::define" namespace to add functions to the define vocabulary, is this going to be blessed or is there an approved alternative? I thought that I should be able to call "method" directly from my new proc "accessor" since I'm in the oo::class creat context, but I needed to wrap it in "oo::define" which I think is also OK. This requires the access of the current class name with the funky [info level -1] call. This seems a little fragile.
proc oo::define::accessor args {
set currentclass [lindex [info level -1] 1]
foreach var $args {
oo::define $currentclass [subst { method $var args { set $var {*}\$args } }]
}
}
oo::class create X {
variable a b c
accessor a b
constructor {} {
set a 1
}
}
X create x
x a 3
puts [x a]Aud I'll put this here for any TclOO newbies like me. Here's what I'm doing for clean, easy accessors. Firstly a mixin to map "get/set var" to private methods Get_var/Set_var.
oo::class create get_set_mixin {
method get {name} {
set method "Get_$name"
if {$method ni [info object methods [self] -all -private]} {
error "accessor not defined for \"$name\""}
return [uplevel 1 [list {*}[namespace code my] $method]]
}
method set {name value} {
set method "Set_$name"
if {$method ni [info object methods [self] -all -private]} {
error "mutator not defined for \"$name\""}
return [uplevel 1 [list {*}[namespace code my] $method $value]]
}
}Secondly, a sort of macro to fill in simple, unchecked accessors.
proc oo_simple_accessor {name} {
return [list method Get_$name {} "return \[set \[my varname [list $name]\]\]"]
}
proc oo_simple_mutator {name} {
return [list method Set_$name {value} "return \[set \[my varname [list $name]\] \$value\]"]
}Combined, you can do something like this:
% oo::class create test_class {
mixin get_set_mixin
constructor {} {
variable var1 ""
variable var2 ""
}
{*}[oo_simple_accessor var1]
{*}[oo_simple_accessor var2]
{*}[oo_simple_mutator var1]
method Set_var2 {value} {
if {![string is integer $value]} {
error "value must be an integer"}
variable var2
return [set var2 $value]
}
}
::test_class
% test_class create testobj
::testobj
% testobj set var1 "Hello world!"
Hello world!
% testobj set var2 blah
value must be an integer
% testobj set var2 1234
1234
% puts "[testobj get var1] [testobj get var2]"
Hello world! 1234AMG: Just a note regarding your recent edit (set var2 $value → return [set var2 $value])... these two forms do exactly the same thing since they're the last command in the method (which works like a proc), and the default return value of a proc is the return value of the last thing it did.
Aud - Yeah, I do know this. I edited it to be consistent with the other code. It's basically my stylistic preference, I like explicit returns. That being said, if anyone wants to use this code, you can actually take out every use of return if you want to, I'm pretty sure.
DKF: Let's integrate that accessor code a little bit better, assuming you're using Tcl 8.6 (for tailcall; if not, you'll need something with uplevel):
proc ::oo::define::simple_accessor {name} {
tailcall method Get_$name {} "return \[set \[my varname [list $name]\]\]"
}
proc ::oo::objdefine::simple_accessor {name} {
tailcall method Get_$name {} "return \[set \[my varname [list $name]\]\]"
}
proc ::oo::define::simple_mutator {name} {
tailcall method Set_$name {value} "return \[set \[my varname [list $name]\] \$value\]"
}
proc ::oo::define::simple_mutator {name} {
tailcall method Set_$name {value} "return \[set \[my varname [list $name]\] \$value\]"
}However, it's nicer if we can just say property foo (plus your original mixin class definition, from above):
proc ::oo::define::property {name {accessMode "read write"}} {
set cls [lindex [info level -1] 1]
if {"::get_set_mixin" ni [info class mixins $cls]} {
uplevel 1 [list mixin ::get_set_mixin]
}
if {"read" in $accessMode} {
uplevel 1 [list method Get_$name {} "return \[set \[my varname [list $name]\]\]"]
}
if {"write" in $accessMode} {
uplevel 1 [list method Set_$name {value} "return \[set \[my varname [list $name]\] \$value\]"]
}
}This lets us write this:
% oo::class create test_class {
constructor {} {
variable var1 ""
variable var2 ""
}
property var1
property var2
}
::test_class
% test_class create testobj
::testobj
% testobj set var1 "Hello world!"
Hello world!
% testobj get var1
Hello world!Where it gets more complex is when you want to have the property also declare the initial value. That's where it probably becomes reasonable to ask me to do some core implementation work…
Aud - Well that would be a nice feature. :-) I was initially confused that oo::define variable doesn't do that. Actually, I'm still kinda confused what the use for it is, anyway. The manpage suggests that it's like an auto variable command in every method, but that doesn't seem to happen.
Twylite 2013-03-01: Examples on this page use various techniques to discover the class that you're defining from within an oo::define::* proc. These techniques are fragile and may not behave correctly if your class is an a namespace, or if the class name is a variable or the result of a command. I suggest the following helper:
proc ::oo::DefWhat {} {
uplevel 3 [list ::namespace which [lindex [info level -2] 1]]
}A helper is preferable to adding the logic inline, as the stack levels are specific to the current implementation of TclOO, and could change in the future. This command could also be implemented in C to provide guaranteed correctness.
Usage:
proc ::oo::define::foo {args} {
set cls [::oo::DefWhat]
puts "define 'foo' on class '$cls', args='$args'"
}
oo::define oo::class foo bar
namespace eval oo { define class foo bar }
namespace eval someNs {
oo::class create SomeClass {
foo bar
}
oo::define SomeClass foo baz
oo::class create ::AnotherClass {
foo bar
}
}In this comp.lang.tcl thread , there was a desire expressed to have a test for whether a particular word was the name of a class. The solution is slightly messy, but can be wrapped up to create info class exists:
proc oo::InfoClass::exists {className} {
expr {
[uplevel 1 [list info object isa object $className]] &&
[uplevel 1 [list info object isa class $className]]
}
} After doing that (which adds another subcommand to the appropriate ensemble) the test then becomes just:
% info class exists oo::object 1 % info class exists fred 0
DKF: Someone was asking for RAII with TclOO on tcl-core . You can do it (with an unset variable trace that calls destroy) but it is more elegant and more Tcl-ish to scope an object's lifetime to a block. Tcl doesn't really have blocks, of course, but we can pretend just fine.
oo::class create Context {
method as {varname in body} {
upvar 1 $varname v
set v [self]
try {
uplevel 1 $body
} finally {
unset -nocomplain v
catch {my destroy}
}
}
}This class is intended to be used as a mixin, but you can directly inherit from it too. Here's an example of how it might work:
oo::class create FileExample {
mixin Context
variable f
constructor {filename} {
set f [open $filename]
}
destructor {
close $f
}
method gets {} {
gets $f
}
# A real file handle class would have a lot more methods here, of course
}
# Use it with a block
[FileExample new "/tmp/foo.txt"] as channel in {
puts [$channel gets]
puts [$channel gets]
}Once that "block" finishes, either with an error or without, the object will be cleanly destroyed and its resources released (with a sensible destructor).
dzach 2018-02-28 Here is a proc that can be used in the defScript of a class to set some initial values:
proc ::oo::define::classvar {varName value} {
set cns [info object namespace [lindex [info level -1] 1]]
namespace eval $cns [list ::set $varName $value]
}Demo:
% ::oo::class create a {
classvar var "this is a test"
method get varName {
namespace upvar [info object namespace [self class]] $varName $varName
set $varName
}
}
::a
% a create b
::b
%b get var
this is a test
% time {b get var} 100000
3.107018 microseconds per iterationA more elegant way to gain access of a variable in a class's namespace, from a method, is ::oo::Helpers::classvar, but how efficient is it? Here are some results:
proc ::oo::Helpers::classvar varName {
tailcall namespace upvar [info object namespace [uplevel 1 self class]] $varName $varName
}
::oo::class create ::a {
method upvar {} {
upvar [info object namespace [self class]]::var var
set var
}
method classvar {} {
classvar var
set var
}
method nsupvar {} {
namespace upvar [info object namespace [self class]] var var
set var
}
constructor {} {
namespace upvar [info object namespace [self class]] var var
set var "this is a test"
}
}Testing:
% a create b
::b
% b upvar
this is a test
% time {b upvar} 100000
2.24381 microseconds per iteration
% time {b nsupvar} 100000
1.77978 microseconds per iteration
% time {b classvar} 100000
7.93022 microseconds per iterationThe inline namespace upvar seems to be the winner. Still, finding the namespace of a class seems to take a toll on performance.
sdw's paper has a good exposition of some of these techniques in its introduction section.