#!/usr/bin/tclsh # This is only a small improvement over the previous example. # Instead of accessing the object arrays directly, we access them # through the 'cget' and 'configure' methods. # 'delete' procedure independent of the class proc delete {args} { foreach name $args { upvar #0 $name arr unset arr ; # Deletes the object's data rename $name {} ; # Deletes the object command } } proc class {classname vars methods} { # Create the class command, which will allow new instances to be created. set template { proc @classname@ {obj_name args} { # The class command in turn creates an object command. # Fewer escape characters thanks to the '@' sign. proc $obj_name {command args} \ "return \[eval dispatch_@classname@ $obj_name \$command \$args\]" # Set variable defaults upvar #0 $obj_name arr array set arr {@vars@} # Then possibly override those defaults with user-supplied values if { [llength $args] > 0 } { eval $obj_name configure $args } } } regsub -all @classname@ $template $classname template regsub -all @vars@ $template $vars template eval $template # Create the dispatcher, which dispatches to one of the class methods set template { proc dispatch_@classname@ {obj_name command args} { upvar #0 $obj_name arr if { $command == "configure" || $command == "config" } { array set arr $args } elseif { $command == "cget" } { return $arr([lindex $args 0]) } else { if { [lsearch {@methods@} $command] != -1 } { uplevel 1 @classname@_${command} $obj_name $args } else { puts "Error: Unknown command $command" } } } } regsub -all @classname@ $template $classname template regsub -all @methods@ $template $methods template eval $template } class apple {-color green -size 5 -price 10} {byte} proc apple_byte {self} { puts "Taking a byte from apple $self" $self configure -size [expr [$self cget -size] - 1] if { [$self cget -size] <= 0 } { puts "Apple $self now completely eaten! Deleting it..." delete $self } } class fridge {-state closed -label A} {open close} proc fridge_open {self} { if { [$self cget -state] == "open" } { puts "Fridge $self already open." } else { $self configure -state "open" puts "Opening fridge $self..." } } proc fridge_close {self} { if { [$self cget -state] == "closed" } { puts "Fridge $self already closed." } else { $self configure -state "closed" puts "Closing fridge $self..." } } apple a1 -size 3 apple a2 -color yellow -size 3 foreach i {1 2 3} { a1 byte a2 byte } fridge f1 -state open f1 close f1 close f1 open f1 open f1 close