54 lines
1.4 KiB
Tcl
54 lines
1.4 KiB
Tcl
package require TclOO
|
|
|
|
oo::class create Delegate {
|
|
method thing {} {
|
|
return "delegate impl."
|
|
}
|
|
export thing
|
|
}
|
|
|
|
oo::class create Delegator {
|
|
variable delegate
|
|
constructor args {
|
|
my delegate {*}$args
|
|
}
|
|
|
|
method delegate args {
|
|
if {[llength $args] == 0} {
|
|
if {[info exists delegate]} {
|
|
return $delegate
|
|
}
|
|
} elseif {[llength $args] == 1} {
|
|
set delegate [lindex $args 0]
|
|
} else {
|
|
return -code error "wrong # args: should be \"[self] delegate ?target?\""
|
|
}
|
|
}
|
|
|
|
method operation {} {
|
|
try {
|
|
set result [$delegate thing]
|
|
} on error e {
|
|
set result "default implementation"
|
|
}
|
|
return $result
|
|
}
|
|
}
|
|
|
|
# to instantiate a named object, use: class create objname; objname aMethod
|
|
# to have the class name the object: set obj [class new]; $obj aMethod
|
|
|
|
Delegator create a
|
|
set b [Delegator new "not a delegate object"]
|
|
set c [Delegator new [Delegate new]]
|
|
|
|
assert {[a operation] eq "default implementation"} ;# a "named" object, hence "a ..."
|
|
assert {[$b operation] eq "default implementation"} ;# an "anonymous" object, hence "$b ..."
|
|
assert {[$c operation] ne "default implementation"}
|
|
|
|
# now, set a delegate for object a
|
|
a delegate [$c delegate]
|
|
assert {[a operation] ne "default implementation"}
|
|
|
|
puts "all assertions passed"
|