oo.tcl

   1 # OO support for Jim Tcl, with multiple inheritance
   2
   3 # Create a new class $classname, with the given
   4 # dictionary as class variables. These are the initial
   5 # variables which all newly created objects of this class are
   6 # initialised with.
   7 #
   8 # If a list of baseclasses is given,
   9 # methods and instance variables are inherited.
  10 # The *last* baseclass can be accessed directly with [super]
  11 # Later baseclasses take precedence if the same method exists in more than one
  12 proc class {classname {baseclasses {}} classvars} {
  13         foreach baseclass $baseclasses {
  14                 # Start by mapping all methods to the parent class
  15                 foreach method [$baseclass methods] { alias "$classname $method" "$baseclass $method" }
  16                 # Now import the base class classvars
  17                 set classvars [dict merge $classvars [$baseclass classvars]]
  18                 # The last baseclass will win here
  19                 proc "$classname baseclass" {} baseclass { return $baseclass }
  20         }
  21
  22         # Make sure that classvars is a dictionary
  23         set vars [lsort [dict keys $classvars]]
  24
  25         # This is the class dispatcher for $classname
  26         # It simply dispatches 'classname cmd' to a procedure named {classname cmd}
  27         # with a nice message if the class procedure doesn't exist
  28         proc $classname {{cmd new} args} classname {
  29                 if {![exists -proc "$classname $cmd"]} {
  30                         return -code error "$classname, unknown command \"$cmd\": should be [join [$classname methods] ", "]"
  31                 }
  32                 tailcall "$classname $cmd" {*}$args
  33         }
  34
  35         # Constructor
  36         proc "$classname new" {{instvars {}}} {classname classvars} {
  37                 set instvars [dict merge $classvars $instvars]
  38
  39                 # This is the object dispatcher for $classname.
  40                 # Store the classname in both the ref value and tag, for debugging
  41                 # ref tag (for debugging)
  42                 proc [ref $classname $classname "$classname finalize"] {method args} {classname instvars} {
  43                         if {![exists -proc "$classname $method"]} {
  44                                 return -code error "$classname, unknown method \"$method\": should be [join [$classname methods] ", "]"
  45                         }
  46                         "$classname $method" {*}$args
  47                 }
  48         }
  49         # Finalizer to invoke destructor during garbage collection
  50         proc "$classname finalize" {ref classname} { $ref destroy }
  51         # Method creator
  52         proc "$classname method" {method arglist body} classname {
  53                 proc "$classname $method" $arglist {body} {
  54                         # Make sure this isn't incorrectly called without an object
  55                         if {![uplevel exists instvars]} {
  56                                 return -code error -level 2 "\"[lindex [info level 0] 0]\" method called with no object"
  57                         }
  58                         set self [lindex [info level -1] 0]
  59                         # Note that we can't use 'dict with' here because
  60                         # the dict isn't updated until the body completes.
  61                         foreach _ [$self vars] {upvar 1 instvars($_) $_}
  62                         unset _
  63                         eval $body
  64                 }
  65         }
  66         # Other simple class procs
  67         proc "$classname vars" {} vars { return $vars }
  68         proc "$classname classvars" {} classvars { return $classvars }
  69         proc "$classname classname" {} classname { return $classname }
  70         proc "$classname methods" {} classname {
  71                 lsort [lmap p [info procs "$classname *"] {
  72                         lindex [split $p " "] 1
  73                 }]
  74         }
  75         # Pre-defined some instance methods
  76         $classname method destroy {} { rename $self "" }
  77         $classname method get {var} { set $var }
  78         $classname method eval {{locals {}} code} {
  79                 foreach var $locals { upvar 2 $var $var }
  80                 eval $code
  81         }
  82         return $classname
  83 }
  84
  85 # From within a method, invokes the given method on the base class.
  86 # Note that this will only call the last baseclass given
  87 proc super {method args} {
  88         upvar self self
  89         uplevel 2 [$self baseclass] $method {*}$args
  90 }