#!/usr/bin/tclsh # - We introduce a 'delete' procedure to clean up objects when we no longer need them. # - We give some of the attributes default values, which are set in the constructor. proc get_color {obj_name} { global a_color if { [info exists a_color($obj_name)] } { return $a_color($obj_name) } else { puts "Warning: $obj_name has no color!" return "transparent" ; # return a default color } } proc set_color {obj_name color} { global a_color set a_color($obj_name) $color } proc dispatch {obj_name command args} { if { $command == "get_color" } { return [get_color $obj_name] } elseif { $command == "set_color" } { set_color $obj_name [lindex $args 0] } else { puts "Error: Unknown command $command" } } proc apple {args} { global a_color foreach name $args { proc $name {command args} \ "return \[eval dispatch $name \$command \$args\]" set a_color($name) green } } proc delete_apple {args} { global a_color foreach name $args { unset a_color($name) ; # Deletes the object's data rename $name {} ; # Deletes the object command } } apple a1 a2 a3 a2 set_color yellow a3 set_color red puts "a1 has color [a1 get_color]" ; # Uses default color green puts "a2 has color [a2 get_color]" puts "a3 has color [a3 get_color]" delete_apple a1 a2 a3 ; # Delete the objects.