[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].

----

**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]
        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
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`"

[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: last
======

How 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.Delegate
======
Demonstrating…
======
oo::class create ActiveRecord {
    classmethod find args { puts "[self] called with arguments: $args" }
}
oo::class create Table {
    superclass ActiveRecord
}
Table find foo bar
======
which will write this out (I tested it):
======none
::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 http://core.tcl.tk/tcllib/tktview/fe7a0e0a3a1efe3613eddb6de175b155853f2abc%|%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 go could 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.


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

[gasty] 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:

   * use the full namespace path for "name"
   * the destroy method should take care of delete the aliases created...

[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 http://wiki.tcl.tk/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     = my
======

[DKF]: 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.
----

**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]
}
======

[Twylite] 2013-03-01: See 'Finding The Class You're Defining' below for a less fragile way to identify the current class.

----

**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...

[manveru]: The code above doesn't seem to work anymore, you can replace the uplevel command with:

======
::oo::define $currentclass variable {*}$vars
======

[DKF]: With the trunk, (a more sophisticated version of) this is part of the baseline functionality.

----

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

----

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

From [dkf]'s notes in the Tclers chat:

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

Notes:

   1. [[[self - TclOO%|%self] class]] returns the class that declared the current method
   1. [[[info object] namespace]] is very useful for breaking the wall of abstraction
   1. [[[namespace upvar]]] is more efficient than [upvar] and string manipulation

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

----

**Method Annotations**

[DKF]: You can do a lot with scripting. Here's an example from [TclOO Annotations%|%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]
======

----

**Class Derivations Made Easy**

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:

======none
% 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
::x
======

----

**XOTcl/Ruby like Accessors**

This 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]
======
**Simple accessor methods**
[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! 1234
======

[AMG]: 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.


----
**Finding The Class You're Defining**

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

----
**Testing if you've got a class**
In [https://groups.google.com/forum/?hl=en-GB&fromgroups#!topic/comp.lang.tcl/kucfKPPasX4%|%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
======

----
[sdw]'s [http://www.tclcommunityassociation.org/wub/proceedings/Proceedings-2012/SeanWoods/Lifecycle-of-Objects.pdf%|%paper] has a good exposition of some of these techniques in its introduction section.
<<categories>> Object Orientation