Richard Suchenwirth 2007-10-20 - Now that I have TclOO both at work and home, and another weekend comes up, it's obvious that I wanted to play with it, just for finger practice. Barking dogs have been demonstrated elsewhere, but I decided to start with another classic example, a bank account.
#!/usr/bin/env tclsh85
package require TclOO
namespace import oo::*
catch {Account destroy} ;# in case of repeated sourcing
class create Account {
constructor {{ownerName undisclosed}} {
my variable total overdrawLimit owner
set total 0
set overdrawLimit 10
set owner $ownerName
}
method deposit amount {
my variable total
set total [expr {$total + $amount}]
}
method withdraw amount {
my variable {*}[info object vars [self]] ;# "auto-import" all variables
if {($amount - $total) > $overdrawLimit} {
error "Can't overdraw - total: $total, limit: $overdrawLimit"
}
set total [expr {$total - $amount}]
}
method transfer {amount targetAccount} {
my variable total
my withdraw $amount
$targetAccount deposit $amount
set total
}
destructor {
my variable total
if {$total} {puts "remaining $total will be given to charity"}
}
}if 0 {Due to the simple hierarchy of TclOO (every class is an instance of oo::class, which is an subclass of oo::object - while at the same time oo::object is an instance of oo::class), it is not very hard to add development helper methods that each object inherits. For instance, this dumps an object's class and instance variables into a dict-able list:}
define oo::object method dump {{pat *}} {
set res [list class [info object class [self]]]
foreach i [info object vars [self] $pat] {
my variable $i
lappend res $i [set $i]
}
set res
}#-- "Test suite"
foreach cmd [split {
set a [Account new "John Doe"]
$a deposit 200
$a deposit 20
$a withdraw 150
$a withdraw 100
$a dump
set b [Account new]
$a transfer 65 $b
$a dump
$b dump
$a transfer 1000000 $b
$b destroy
} \n] {
catch $cmd res
puts "$cmd -> $res"
}if 0 {which prints
set a [Account new "John Doe"] -> ::oo::Obj36
$a deposit 200 -> 200
$a deposit 20 -> 220
$a withdraw 150 -> 70
$a withdraw 100 -> Can't overdraw - total: 70, limit: 10
$a dump -> class ::Account total 70 overdrawLimit 10 owner {John Doe}
set b [Account new] -> ::oo::Obj37
$a transfer 65 $b -> 5
$a dump -> class ::Account total 5 overdrawLimit 10 owner {John Doe}
$b dump -> class ::Account total 65 overdrawLimit 10 owner undisclosed
$a transfer 1000000 $b -> Can't overdraw - total: 5, limit: 10
remaining 65 will be given to charity
$b destroy ->Interactive testing is, as usual with Tcl, a good way to learn. In the following case, it shows that variables are not exactly protected from hack attacks:
% set $a\::total 1000000
1000000
% $a dump
class ::Account total 1000000 overdrawLimit 10 owner {John Doe}So better not deploy a real banking software based on this code :^) On the lighter side, introspection works as we all know and love, for easy "online help":
% class help unknown method "help": must be create, destroy or dump % Account help unknown method "help": must be create, destroy, dump or new % $a help unknown method "help": must be deposit, destroy, dump, transfer or withdraw
Another issue: member variables must be explicitly imported into methods (similar to namespace rules). If you prefer the C++ style (all member variables implicitly known), one hackish solution was demonstrated in the withdraw method above, and here's some sugar-coating if you want it more often:
proc all_my_variables {} {
uplevel 1 {my variable {*}[info object vars [self]]}
}so the method can then look like
method withdraw amount {
all_my_variables
if {($amount - $total) > $overdrawLimit} {
error "Can't overdraw - total: $total, limit: $overdrawLimit"
}
set total [expr {$total - $amount}]
}To distinguish members and others, one might then use the C++ convention that member names end in "_".
To summarize my first impressions, TclOO can be used well as an OO system in itself. I haven't even used all features as documented in TIP #257. So when I'll need some OO in the future, I can probably just use this, and do without incr Tcl or XOTcl ... :^)
}
The most part of the above example was also included in http://en.wikibooks.org/wiki/Tcl_Programming/Introduction#TclOO - everyone is welcome to make it better!
DKF: Well, you can go one better:
oo::class create class {
superclass oo::class
constructor {args} {
my variable vars
set vars {}
next {*}$args
}
method global {variable {initValue {}}} {
my variable vars
lappend vars $variable $initValue
}
method constructor {args body} {
my variable vars
set body0 {}
foreach {var val} $vars {append body0 [list variable $var $val] \;}
oo::define [self] constructor $args $body0$body
}
method method {name args body} {
my variable vars
set body0 {}
foreach {var val} $vars {append body0 [list variable $var] \;}
oo::define [self] method $name $args $body0$body
}
method destructor body {
my variable vars
set body0 {}
foreach {var val} $vars {append body0 [list variable $var] \;}
oo::define [self] destructor $body0$body
}
}
class create Account
Account global total 0
Account global overdrawLimit 10
Account global owner
Account constructor {{ownerName undisclosed}} {
set owner $ownerName
}
Account method deposit amount {
set total [expr {$total + $amount}]
}
Account method withdraw amount {
if {($amount - $total) > $overdrawLimit} {
error "Can't overdraw - total: $total, limit: $overdrawLimit"
}
set total [expr {$total - $amount}]
}
Account method transfer {amount targetAccount} {
my withdraw $amount
$targetAccount deposit $amount
return $total
}
Account destructor {
if {$total} {puts "remaining $total will be given to charity"}
}DKF: And then there's another step beyond...
oo::class create globalizedClass {
superclass oo::class
constructor {args} {
my variable vars
set vars {}
foreach m {global constructor method destructor} {
interp alias {} [self namespace]::$m {} [self] $m
}
my eval {*}$args
}
method global {variable {initValue {}}} {
my variable vars
lappend vars $variable $initValue
}
method constructor {args body} {
my variable vars
set body0 variable
foreach {var val} $vars {lappend body0 $var $val}
oo::define [self] constructor $args $body0\;$body
}
method method {name args body} {
my variable vars
set body0 {my variable}
foreach {var val} $vars {lappend body0 $var}
oo::define [self] method $name $args $body0\;$body
}
method destructor body {
my variable vars
set body0 {my variable}
foreach {var val} $vars {lappend body0 $var}
oo::define [self] destructor $body0\;$body
}
}
globalizedClass create Account {
global total 0
global overdrawLimit 10
global owner
constructor {{ownerName undisclosed}} {
set owner $ownerName
}
method deposit amount {
set total [expr {$total + $amount}]
}
method withdraw amount {
if {($amount - $total) > $overdrawLimit} {
error "Can't overdraw - total: $total, limit: $overdrawLimit"
}
set total [expr {$total - $amount}]
}
method transfer {amount targetAccount} {
my withdraw $amount
$targetAccount deposit $amount
return $total
}
destructor {
if {$total} {puts "remaining $total will be given to charity"}
}
}It's because it can support this sort of thing that I like to think of TclOO as being a kit for building OO systems.
SL: Another interesting customizing on the meta-class oo::class inspired by Putting Metaclasses to Work [Ira R. Forman, Scott H. Danforth]:
Each newly created oo::object should contain a timestamp, holding the creation-time of each instance.
One implementation is called instance method:
oo::class create ctimestamped {
method create {args} {
next {*}$args
oo::define [lindex $args 0] constructor {args} {
my variable timestamp
set timestamp [clock seconds]
next {*}$args
}
oo::define [lindex $args 0] method getCreationTime {} {
my variable timestamp
return $timestamp
}
}
}
oo::define oo::class mixin ctimestamped
...
set a [Account new]
$a getCreationTimeThe timestamp is located in the class instance as well as the retrieving function.
Another implementation is called class method:
oo::class create ctimestamped {
method create {args} {
next {*}$args
oo::define [lindex $args 0] constructor {args} {
my variable timestamp
set timestamp [clock seconds]
next {*}$args
}
}
method getCreationTime object {
set ${object}::timestamp
}
}
oo::define oo::class mixin ctimestamped
...
set a [Account new]
Account getCreationTime $aThe timestamp is located in the class instance, but the retrieving function is located in the meta-class oo::class.
[tb] 2008-09-24 - How about cascading message posts?
set aLine [[[MyString appendString AnotherString] append "\n"] printString]
isn't quite comfortable, isn't it?
DKF: I can't say that I'm too keen on that sort of usage either, but then again I'd just point out that that's using a perfectly Tcl-ish system in a non-Tcl-ish way. As such, "not a real problem". (I'd instead have the append method take a variable number of arguments and return the resulting string. Which *is* Tcl-ish…)
tb: Ahh... - yes, I see. It'd be nice to have, but it wouldn't be Tcl-ish enough to integrate well. TclTk isn't Smalltalk :)