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                 proc [ref $classname $classname "$classname finalize"] {method args} {classname instvars} {
  45                         if {![exists -command "$classname $method"]} {
  46                                 return -code error "$classname, unknown method \"$method\": should be [join [$classname methods] ", "]"
  47                         }
  48                         "$classname $method" {*}$args
  49                 }
  50         }
  51         # Finalizer to invoke destructor during garbage collection
  52         proc "$classname finalize" {ref classname} { $ref destroy }
  53         # Method creator
  54         proc "$classname method" {method arglist body} classname {
  55                 proc "$classname $method" $arglist {body} {
  56                         # Make sure this isn't incorrectly called without an object
  57                         if {![uplevel exists instvars]} {
  58                                 return -code error -level 2 "\"[lindex [info level 0] 0]\" method called with no object"
  59                         }
  60                         set self [lindex [info level -1] 0]
  61                         # Note that we can't use 'dict with' here because
  62                         # the dict isn't updated until the body completes.
  63                         foreach _ [$self vars] {upvar 1 instvars($_) $_}
  64                         unset _
  65                         eval $body
  66                 }
  67         }
  68         # Other simple class procs
  69         proc "$classname vars" {} vars { return $vars }
  70         proc "$classname classvars" {} classvars { return $classvars }
  71         proc "$classname classname" {} classname { return $classname }
  72         proc "$classname methods" {} classname {
  73                 lsort [lmap p [info procs "$classname *"] {
  74                         lindex [split $p " "] 1
  75                 }]
  76         }
  77         # Pre-defined some instance methods
  78         $classname method destroy {} { rename $self "" }
  79         $classname method get {var} { set $var }
  80         $classname method eval {{locals {}} code} {
  81                 foreach var $locals { upvar 2 $var $var }
  82                 eval $code
  83         }
  84         return $classname
  85 }
  86
  87 # From within a method, invokes the given method on the base class.
  88 # Note that this will only call the last baseclass given
  89 proc super {method args} {
  90         upvar self self
  91         uplevel 2 [$self baseclass] $method {*}$args
  92 }