Little Sugar for Stooop object system:
it uses some internals of Stooop, but it is necessary coz stoop doesnt export a proc to tell the ancestors of a class. I need sujestions for this little sugar ^^.
#------------------------------------------------------------------------------
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 |
|---|