[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
 }
if 0 {see also [Serializing TclOO objects]}
#-- "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 getCreationTime
The 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 $a
The 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 :)

[Lars H]: While I don't see much point in this construction either, I'd like to remark that the TIP#314 [http://tip.tcl.tk/314] mechanism supports it. After
======
namespace eval String {
    # The namespace ensemble is a "class". Its "objects" are command prefixes
    # starting with the command My, which is the dispatch ensemble.
    namespace export {[a-z]*}
    namespace ensemble create -parameters str\
      -command [namespace current]::My
    # Object constructor:
    proc Create {str} {
        list [namespace which My] $str
    }
    # Public methods:
    proc serialize {str} {return $str}
    proc append {str str2} {
        Create "$str$str2"
    }
    proc appendString {str strObj} {
        Create "$str[{*}$strObj serialize]"
    }
    # Public alias for object constructor:
    interp alias {} [namespace current] {} [namespace current]::Create
}
======
you can do
======
set MyString [String "foo "]               
set AnotherString [String "bar."]
set aLine [{*}[{*}[{*}$MyString appendString $AnotherString] append "\n"] serialize]
======
which I think is effectively what was asked for (though I might be mistaken about printString being a serialize operation).


----
[GPS]: That looks bizarre with all the {*} syntax.  I can do it this way:

 proc String s {
         set obj [objstructure]

         $obj ::add-keys string $s
         $obj ::add-method append [list String-append $obj]
         $obj ::add-method printString [list String-printString $obj]

         return $obj
 }

 proc String-append {obj append} {
         set s [$obj string]
         append s $append
         $obj string $s
         return $obj
 }

 proc String-printString {obj chan} {
         puts $chan [$obj string]
         return $obj
 }

 set aLineString [[[String "Hello World"] append "!  Give me a cookie!"] printString stdout]
 #prints to stdout: "Hello World!  Give me a cookie!"
 
 #if you want to cleanup do: rename $aLineString {} or add a destroy method that does that.
 #Reference counting could be done too, with release and retain messages.

[tb] - :) - My question was more about a more convenient syntax for cascading message posts. If you have a series of messages to be sent to the same object, then why always construct a full message post? Given, that every method that doesn't return a certain value, instead returns '''self''', one could wright:

 SomeObject doSomething appendTo [AnotherObject copesWith anArgument] print

[RS] Umm.. usual OO models as I know them treat one method call as a unit. Your proposed calling style is certainly doable, but would involve some parsing of the arguments to decide which are method names, and which are arguments to methods. I'm not sure whether it's worth that when you can just code (as usual):
 $obj doSomething
 $obj appendTo [$obj2 copeswith $arg]
 $obj print
which looks still better readable to me... :^)

----
!!!!!!
%| [Category Example] | [Category Object orientation] |%
!!!!!!