Update autosetup to v0.6.8
[jimtcl.git] / oo.tcl
blobb6ad4a9cfde20a3ddb475b3bd2bc6279e7e1eef3
1 # OO support for Jim Tcl, with multiple inheritance
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.
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 }
23 # Merge in the baseclass vars with lower precedence
24 set classvars [dict merge $baseclassvars $classvars]
25 set vars [lsort [dict keys $classvars]]
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] ", "]"
34 tailcall "$classname $cmd" {*}$args
37 # Constructor
38 proc "$classname new" {{instvars {}}} {classname classvars} {
39 set instvars [dict merge $classvars $instvars]
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] ", "]"
50 return ["$classname unknown" $method {*}$args]
52 "$classname $method" {*}$args
54 if {[exists -command "$classname constructor"]} {
55 $obj constructor
57 return $obj
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"
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 __
73 eval $__body
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
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
92 return $classname
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