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         set baseclassvars {}
  14         foreach baseclass $baseclasses {
  15                 # Start by mapping all methods to the parent class
  16                 foreach method [$baseclass methods] { alias "$classname $method" "$baseclass $method" }
  17                 # Now import the base class classvars
  18                 set baseclassvars [dict merge $baseclassvars [$baseclass classvars]]
  19                 # The last baseclass will win here
  20                 proc "$classname baseclass" {} baseclass { return $baseclass }
  21         }
  22
  23         # Merge in the baseclass vars with lower precedence
  24         set classvars [dict merge $baseclassvars $classvars]
  25         set vars [lsort [dict keys $classvars]]
  26
  27         # This is the class dispatcher for $classname
  28         # It simply dispatches 'classname cmd' to a procedure named {classname cmd}
  29         # with a nice message if the class procedure doesn't exist
  30         proc $classname {{cmd new} args} classname {
  31                 if {![exists -command "$classname $cmd"]} {
  32                         return -code error "$classname, unknown command \"$cmd\": should be [join [$classname methods] ", "]"
  33                 }
  34                 tailcall "$classname $cmd" {*}$args
  35         }
  36
  37         # Constructor
  38         proc "$classname new" {{instvars {}}} {classname classvars} {
  39                 set instvars [dict merge $classvars $instvars]
  40
  41                 # This is the object dispatcher for $classname.
  42                 # Store the classname in both the ref value and tag, for debugging
  43                 # ref tag (for debugging)
  44                 set obj [ref $classname $classname "$classname finalize"]
  45                 proc $obj {method args} {classname instvars} {
  46                         if {![exists -command "$classname $method"]} {
  47                                 if {![exists -command "$classname unknown"]} {
  48                                         return -code error "$classname, unknown method \"$method\": should be [join [$classname methods] ", "]"
  49                                 }
  50                                 return ["$classname unknown" $method {*}$args]
  51                         }
  52                         "$classname $method" {*}$args
  53                 }
  54                 if {[exists -command "$classname constructor"]} {
  55                         $obj constructor
  56                 }
  57                 return $obj
  58         }
  59         # Finalizer to invoke destructor during garbage collection
  60         proc "$classname finalize" {ref classname} { $ref destroy }
  61         # Method creator
  62         proc "$classname method" {method arglist __body} classname {
  63                 proc "$classname $method" $arglist {__body} {
  64                         # Make sure this isn't incorrectly called without an object
  65                         if {![uplevel exists instvars]} {
  66                                 return -code error -level 2 "\"[lindex [info level 0] 0]\" method called with no object"
  67                         }
  68                         set self [lindex [info level -1] 0]
  69                         # Note that we can't use 'dict with' here because
  70                         # the dict isn't updated until the body completes.
  71                         foreach __ [$self vars] {upvar 1 instvars($__) $__}
  72                         unset -nocomplain __
  73                         eval $__body
  74                 }
  75         }
  76         # Other simple class procs
  77         proc "$classname vars" {} vars { return $vars }
  78         proc "$classname classvars" {} classvars { return $classvars }
  79         proc "$classname classname" {} classname { return $classname }
  80         proc "$classname methods" {} classname {
  81                 lsort [lmap p [info commands "$classname *"] {
  82                         lindex [split $p " "] 1
  83                 }]
  84         }
  85         # Pre-defined some instance methods
  86         $classname method destroy {} { rename $self "" }
  87         $classname method get {var} { set $var }
  88         $classname method eval {{locals {}} __code} {
  89                 foreach var $locals { upvar 2 $var $var }
  90                 eval $__code
  91         }
  92         return $classname
  93 }
  94
  95 # From within a method, invokes the given method on the base class.
  96 # Note that this will only call the last baseclass given
  97 proc super {method args} {
  98         upvar self self
  99         uplevel 2 [$self baseclass] $method {*}$args
 100 }