Little Sugar for Stooop object system:



#------------------------------------------------------------------------------
proc unknown {cmd args} {
    if {[string index $cmd 0] == "@"} {
        return [stooopSugar $cmd {*}$args]
    } else {
        error "unknown: $cmd $args"
    }
}



proc stooopSugar {cmd args} {
    set parts [split $cmd .]
    set this  [string range [lindex $parts 0] 1 end]
    set method [lindex $parts 1]

    set class [::stooop::classof $this]

   # first check if it is a class method
   if {[info procs ${class}::${method}] != ""} {
       return [${class}::${method} $this {*}$args]
   }

   # now checks if it is a ancestor method

    set baseClasses $::stooop::fullBases($class)

    foreach class $baseClasses {
        if {[info procs ${class}::${method}] != ""} {
             ${class}::${method} $this {*}$args
        } else {
            error "there is no suck method $method on class $class"
        }
    }
}
#------------------------------------------------------------------------------

Usage:


package require stooop 4                                  ;# load stooop package
namespace import stooop::*                ;# and import class, new, ... commands

class shape {                                           ;# base class definition
    proc shape {this x y} {                            ;# base class constructor
        set ($this,x) $x                           ;# data member initialization
        set ($this,y) $y
    }
    proc ~shape {this} {}                               ;# base class destructor
    # pure virtual draw: must be implemented in derived classes
    virtual proc draw {this}
    virtual proc rotate {this angle} {}                 ;# do nothing by default
}
proc shape::move {this x y} {            ;# external member procedure definition
    set ($this,x) $x
    set ($this,y) $y
    draw $this               ;# shape::draw invokes derived class implementation
    puts "and I moved to ($x,$y)"
}

class triangle {                                             ;# class definition
    proc triangle {this x y} shape {$x $y} {               ;# derived from shape
        # triangle constructor implementation
    }
    proc ~triangle {this} {}
    proc draw {this} {
        # triangle specific implementation
        puts "i am a triangle!!!"
    }
    proc rotate {this angle} {
        # triangle specific implementation
    }
}

class circle {}        ;# empty class definition, procedures are defined outside
proc circle::circle {this x y} shape {$x $y} {             ;# derived from shape
    # circle constructor implementation
}
proc circle::~circle {this} {}
proc circle::draw {this} {
    # circle specific implementation
    puts "I am a circle!!!"
}
# circle::rotate procedure is a noop, no need to overload

set s [new  circle 20 20]
@$s.draw 
@$s.move 10 20

set f [new triangle 10 20] 
@$f.move 20 25

----
!!!!!!
%| enter categories here |%
!!!!!!