Snit like Delegation in XOTcl

This example code is from Gustaf Neumann, taken from the XOTcl mailing list [L1 ].

The basic idea of the delegation approach is to define delegation rules for calls of unknown methods. For handling unknown invocations, XOTcl provides the unknown method (which can be defined per class or per object). In the implementation below we define a method 'delegate' for the basic class 'Object' (therefore the method can be used on every class) that stores the delegation information in an associative array (per object). The method 'unknown' retrieves this information and calls the method on the determined object.

 ##############################################################
 # define a delegate method and a default behavior for unknown
 ##############################################################
 Object instproc delegate {method obj} {
   my set delegate($method) $obj
 }
 Object instproc unknown {m args} {
   if {[my exists delegate($m)]} {
     eval [my set delegate($m)] $m $args
   } elseif {[my exists delegate(*)]} {
     eval [my set delegate(*)] $m $args
   }
 }

This definition is sufficient for a basic implementation. We can now use the delegate method in an application. Here we use the example from the snit home page [L2 ]. We define a class 'Tail' with a method 'wag' and Class 'Dog'. The constructor of 'Dog' creates a tail and delegates all unknown calls to the created object (of class 'Tail')

 ##############################################################
 # example from the snit homepage: A dog with a tail....
 ##############################################################
 Class Tail -parameter {{length 5}} 
 Tail instproc wag {} {
   puts "[my info parent] Wag, wag, wag."
 }
 
 Class Dog 
 Dog instproc init {} {
   set tail [Tail new -childof [self]]
   my delegate * $tail
 }
 Dog instproc bark {} {
   puts "[self] Bark, bark, bark."
 }

Now we can create an instance 'fido' of class 'Dog' we we call the methods 'wag' and 'bark' for the instance.

 Dog fido
 fido wag
 fido bark

The output of the methods above is

 ::fido Wag, wag, wag.
 ::fido Bark, bark, bark.

GN Well, there is an updated version of delegate and unknwon based on the builtin forward, introduced by xotcl 1.3.0. This version is much faster, since it uses unknown only for the first invocation on a "delegate *" and ueses forward for later calls. This is about three times faster than the above solution.

 Object instproc delegate {method obj} {
   if {[string first * $method]>-1} {
     puts stderr "storing information in [self]"
     my set delegate($method) $obj
   } else {
     my forward $m $obj $m
   }
 }
 Object instproc unknown {m args} {
   foreach key [my array names delegate] {
     if {[string match $key $m]} {
       set target [my set delegate(*)]
       my forward $m $target $m
       return [eval my $m $args]
     }
   }
 }