Error processing request

Parameters

Body

Error

Unknow state transition: LINE -> END

-code

1

-level

0

-errorstack

INNER {returnImm {Unknow state transition: LINE -> END} {}} CALL {my render_wikit {TclOO Tricks} {[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...
----
**Class Variables**
======
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
2
======

[DKF]: 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,5
======

If you don't have [tailcall], use this instead inside the definition:
 uplevel 1 [list namespace upvar $ns {*}$ns]
----
**Class (Static) Methods**

======
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=7
======

If 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`"
----
**Singletons**
======
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::Obj22
======
----
**Private keyword for methods (working)**
[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]
}
======
----
**Method visibility keyword (private) (2)**
======
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 [uplevel]s 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.
----
**Friendly Objects**
[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
======
----
**Appending Variable Declaration**
[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...
----
**Pool Allocator**
From [http://rosettacode.org/wiki/Allocator#Tcl%|%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
    }
}
======
----
**Easier Callbacks**
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]
======
----
**Ensemble Methods or SNIT-like Methods**
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::ensemble
======
Usage:
======
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

======
----
**Accessing a var in a class namespace from an instance**

upvar [info object namespace [self class]]::var var

Notes:
[self class] returns the class that declared the current method
[info object namespace] is very useful for breaking the wall of abstraction

 proc classvar var {
    set c [uplevel 1 self class]
    tailcall upvar [info object namespace $c]::$var $var
 }

======

<<categories>> Object Orientation} regexp2} CALL {my render {TclOO Tricks} {[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...
----
**Class Variables**
======
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
2
======

[DKF]: 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,5
======

If you don't have [tailcall], use this instead inside the definition:
 uplevel 1 [list namespace upvar $ns {*}$ns]
----
**Class (Static) Methods**

======
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=7
======

If 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`"
----
**Singletons**
======
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::Obj22
======
----
**Private keyword for methods (working)**
[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]
}
======
----
**Method visibility keyword (private) (2)**
======
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 [uplevel]s 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.
----
**Friendly Objects**
[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
======
----
**Appending Variable Declaration**
[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...
----
**Pool Allocator**
From [http://rosettacode.org/wiki/Allocator#Tcl%|%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
    }
}
======
----
**Easier Callbacks**
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]
======
----
**Ensemble Methods or SNIT-like Methods**
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::ensemble
======
Usage:
======
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

======
----
**Accessing a var in a class namespace from an instance**

upvar [info object namespace [self class]]::var var

Notes:
[self class] returns the class that declared the current method
[info object namespace] is very useful for breaking the wall of abstraction

 proc classvar var {
    set c [uplevel 1 self class]
    tailcall upvar [info object namespace $c]::$var $var
 }

======

<<categories>> Object Orientation}} CALL {my revision {TclOO Tricks}} CALL {::oo::Obj331342 process revision/TclOO+Tricks} CALL {::oo::Obj331340 process}

-errorcode

NONE

-errorinfo

Unknow state transition: LINE -> END
    while executing
"error $msg"
    (class "::Wiki" method "render_wikit" line 6)
    invoked from within
"my render_$default_markup $N $C $mkup_rendering_engine"
    (class "::Wiki" method "render" line 8)
    invoked from within
"my render $name $C"
    (class "::Wiki" method "revision" line 31)
    invoked from within
"my revision $page"
    (class "::Wiki" method "process" line 56)
    invoked from within
"$server process [string trim $uri /]"

-errorline

4