The following code is somewhat experimental. I have seen quite a few variations on this theme. However, I believe this code does things in a new and interesting way. This code is not feature complete, it is primarily a proof of concept at this point. Please feel free to make comments and/or criticize this code. If you have feature/code suggestions please feel free to add them to this page. If you would like to submit code changes, please email them to me and I will review them for addition.
This code allows for the following concepts/constructs:
Main Source File (class.tcl)
############################################################################### # # Tcl "class/object" commands # # Part of "Simple class/object commands" -- http://mini.net/tcl/4697 # # Copyright (c) 2002 by Joe Mistachkin. All rights reserved. # # written by: Joe Mistachkin <[email protected]> # created on: 11/18/2002 # modified on: 03/12/2003 # ############################################################################### # # The authors hereby grant permission to use, copy, modify, distribute, # and license this software and its documentation for any purpose, provided # that existing copyright notices are retained in all copies and that this # notice is included verbatim in any distributions. No written agreement, # license, or royalty fee is required for any of the authorized uses. # Modifications to this software may be copyrighted by their authors # and need not follow the licensing terms described here, provided that # the new terms are clearly indicated on the first page of each file where # they apply. # # IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY # FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES # ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY # DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE # POSSIBILITY OF SUCH DAMAGE. # # THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, # INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE # IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE # NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR # MODIFICATIONS. # # GOVERNMENT USE: If you are acquiring this software on behalf of the # U.S. government, the Government shall have only "Restricted Rights" # in the software and related documentation as defined in the Federal # Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you # are acquiring the software on behalf of the Department of Defense, the # software shall be classified as "Commercial Computer Software" and the # Government shall have only "Restricted Rights" as defined in Clause # 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the # authors grant the U.S. Government and others acting in its behalf # permission to use and distribute the software in accordance with the # terms specified in this license. # ############################################################################### # REQUIRES Tcl 8.3+ package require "Tcl" "8.3" # version set class_version "1.60" ############################################################################### proc class_output { arguments {level "-1"} } { # # try to output to stdout, return 1 to indicate success, 0 otherwise. # if {[catch {puts stdout $arguments}] == "0"} then { set result "1" } else { set result "0" } return $result } ############################################################################### proc class_argumentNameList { array_name length } { # # return a list suitable for use with foreach # so that we can "unpack" arguments. # set result "" for {set index "1"} {$index <= $length} {incr index} { lappend result "$array_name\($index\)" } return $result } ############################################################################### proc class_argumentValueList { array_name } { # # return a list of values in the array # upvar "1" $array_name local_array set result "" foreach this_name [lsort -integer -increasing -unique [array names local_array]] { lappend result $local_array($this_name) } return $result } ############################################################################### proc class_validHandle { handle } { # # all identifier handles must start with a letter, # then they may have letters, numbers, the underscore # character, or the period. # if {[regexp -- {^([A-Za-z])([0-9A-Za-z_\.]*)$} $handle] != "0"} then { set result "1" } else { set result "0" } return $result } ############################################################################### proc class_validName { name } { # # all identifier names must start with a letter, # then they may have letters, numbers, and the # underscore character. # if {[regexp -- {^([A-Za-z])([0-9A-Za-z_]*)$} $name] != "0"} then { set result "1" } else { set result "0" } return $result } ############################################################################### proc class_generateName { base } { # # NOTE: dummy loop... need 8 random numbers... # set result $base foreach this_part [list 1 2 3 4 5 6 7 8] { append result [format "%02lX" [expr {int(rand() * 0xFF)}]] } return $result } ############################################################################### proc class_variableDeclarations { name } { # # create a variable declaration section # set result "" foreach this_variable [class_variableNameList $name] { append result "variable $this_variable\n" } return $result } ############################################################################### proc class_variableNameList { name } { global class_names global class_variables if {[class_validName $name] != "0"} then { if {[info exists class_names($name,name)] != "0"} then { set result "" foreach this_name [lsort -increasing [array names class_variables]] { if {[string match "$name,*,name" $this_name] != "0"} then { lappend result $class_variables($this_name) } } } else { # class not found set result "" } } else { set result "" } return $result } ############################################################################### proc class_dispatch { object proc arguments } { global class_bases global class_names global class_procs global class_variables global class_objects if {[class_validHandle $object] != "0"} then { # make sure we have a valid object... if {[class_validObject $object] != "0"} then { # lookup class name from obj handle set name $class_objects($object,name) # make sure it's linked to a valid class... if {[info exists class_names($name,name)] != "0"} then { # we need to know the number of arguments... set numargs [llength $arguments] # translate to real proc name... checking base classes as well... # use -1 for now... to allow for variable number of args... set find_result [class_findProc class_bases class_procs $name $object $proc "-1" "1"] # make sure it's a valid base/derived class that it was found it... if {[llength $find_result] == "2"} then { set this_class_name [lindex $find_result "0"] set this_namespace_name [lindex $find_result "1"] # "unpack" arguments into the array... array set argument_array {} # # WHY was i doing this? # # set argument_name_list [class_argumentNameList argument_array [llength $class_procs($this_class_name,$proc,args)]] # # go for the ACTUAL arguments passed... # set argument_name_list [class_argumentNameList argument_array [llength $arguments]] if {[llength $argument_name_list] != "0"} then { # this is not a bug... # it assigns the loop variables and breaks out foreach $argument_name_list $arguments break } set argument_value_list [class_argumentValueList argument_array] # eval in namespace so we can access private vars... # namespace eval $this_namespace_name $this_class_name.$proc $argument_value_list namespace eval $this_namespace_name $proc $argument_value_list } else { class_output "proc \"$proc\", taking $numargs arguments, not found in class \"$name\"." } } else { class_output "object \"$object\" linked to invalid class \"$name\"." } } else { class_output "object \"$object\" not found." } } else { class_output "invalid object \"$object\"." } } ############################################################################### proc interface { name {body ""} } { global interface_names global interface_procs # # process "interface" definition... # # NOTE: we will only process "proc" declarations # # NOTE: every interface definition must be a valid list. # if {[class_validName $name] != "0"} then { # don't allow duplicate interface declarations if {[info exists interface_names($name,name)] == "0"} then { # must have an even number of arguments... if {[llength $body] % "2" == "0"} then { # # initialize, there is no declaration error # set declaration_error "0" # # did we verify the entire declaration yet? # for {set verified "0"} {$verified <= "1"} {incr verified} { # class_output "processing interface \"$name\" declaration, verified is \"$verified\"..." catch {unset temporary_interface_procs} array set temporary_interface_procs {} set count [llength $body] set index "0" while {(($index < $count) && ($declaration_error == "0"))} { set this_body_part_type [lindex $body $index] # class_output "processing body part type \"$this_body_part_type\", declaration error is \"$declaration_error\"." # no string tolower, this is case sensitive switch -exact -- $this_body_part_type { "comment" { if {$index + "1" < $count} then { # # this is basically a dummy body part, just advance to next one... # # next body part... set index [expr {$index + "2"}] } else { class_output "bad comment declaration." set declaration_error "1" } } "proc" { # proc name {args} {body} if {$index + "3" < $count} then { # +0 == "proc" set this_proc_name [lindex $body [expr {$index + "1"}]] set this_proc_args [lindex $body [expr {$index + "2"}]] set this_proc_body [lindex $body [expr {$index + "3"}]] if {[class_validName $this_proc_name] != "0"} then { if {$verified != "0"} then { if {[info exists interface_procs($name,$this_proc_name,name)] == "0"} then { set proc_exists "0" } else { set proc_exists "1" } } else { # check temp, to see if it's already used. if {[info exists temporary_interface_procs($name,$this_proc_name,name)] == "0"} then { set proc_exists "0" } else { set proc_exists "1" } } if {$proc_exists == "0"} then { if {$verified != "0"} then { # only actually add proc when not running in verification mode... set interface_procs($name,$this_proc_name,name) $this_proc_name set interface_procs($name,$this_proc_name,args) $this_proc_args set interface_procs($name,$this_proc_name,body) $this_proc_body } else { # add to temp, so we know it's already used. set temporary_interface_procs($name,$this_proc_name,name) $this_proc_name set temporary_interface_procs($name,$this_proc_name,args) $this_proc_args set temporary_interface_procs($name,$this_proc_name,body) $this_proc_body } # next body part... set index [expr {$index + "4"}] } else { class_output "proc \"$this_proc_name\" already declared." set declaration_error "2" } } else { class_output "invalid proc name \"$this_proc_name\"." set declaration_error "3" } } else { class_output "bad proc declaration." set declaration_error "4" } } default { # fail, bad declaration type class_output "bad declaration type \"$this_body_part_type\"." set declaration_error "5" } } } } if {$declaration_error == "0"} then { set interface_names($name,name) $name } else { # invalid syntax... # raise error here... class_output "interface \"$name\" declaration error #$declaration_error." } } else { # invalid syntax... # raise error here... class_output "interface \"$name\" declaration error, even number of arguments required." } } else { # interface already defined.. # raise error here... class_output "interface \"$name\" already declared." } } else { # invalid syntax... # raise error here... class_output "invalid interface name \"$name\"." } } ############################################################################### proc class_findProc { base_array_name proc_array_name name object proc numargs derived } { # # search for the proc in the dervied classes, and the base classes, if any. # return a list containing 2 elements if we find it: # # {class name} {namespace name} # # return an empty list for the "not found" and "error" conditions. # if {[class_validName $base_array_name] != "0"} then { if {[class_validName $proc_array_name] != "0"} then { if {[class_validName $name] != "0"} then { # allow empty object for when defining classes only... if {(($object == "") || ([class_validHandle $object] != "0"))} then { if {[string is integer -strict $numargs] != "0"} then { if {[string is integer -strict $derived] != "0"} then { upvar "1" $base_array_name local_base_array upvar "1" $proc_array_name local_proc_array if {[class_hasProc local_base_array local_proc_array $name $proc $numargs "0"] != "0"} then { # it's in the derived class... # just return it set result [list $name $object] } else { # assume not found... set result [list] if {$derived != "0"} then { foreach this_base [array names local_base_array] { # check for bases of our object... if {[string match "$name,*,name" $this_base] != "0"} then { set this_base_name [lindex [split $this_base ","] "1"] if {[class_hasProc local_base_array local_proc_array $this_base_name $proc $numargs "0"] != "0"} then { # bingo! we found it in a base class... set result [list $this_base_name $object.$this_base_name] break } } } } } } else { set result [list] } } else { set result [list] } } else { set result [list] } } else { set result [list] } } else { set result [list] } } else { set result [list] } return $result } ############################################################################### proc class_validObject { object } { global class_objects if {(([info exists class_objects($object,name)] != "0") && ([info exists class_objects($object,object)] != "0") && ([info exists class_objects($object,constructed)] != "0"))} then { set result "1" } else { set result "0" } return $result } ############################################################################### proc class_hasProc { base_array_name proc_array_name name proc numargs derived } { # # check to be sure that the proc exists... # optionally, checking to make sure the number of arguments match. # optionally, checking the base classes (for derived methods). # if {[class_validName $base_array_name] != "0"} then { if {[class_validName $proc_array_name] != "0"} then { if {[class_validName $name] != "0"} then { if {[string is integer -strict $numargs] != "0"} then { if {[string is integer -strict $derived] != "0"} then { upvar "1" $base_array_name local_base_array upvar "1" $proc_array_name local_proc_array # check if it has the proc directly... if {(([info exists local_proc_array($name,$proc,name)] != "0") && ([info exists local_proc_array($name,$proc,args)] != "0") && ([info exists local_proc_array($name,$proc,body)] != "0"))} then { if {$numargs != "-1"} then { if {$numargs == [llength $local_proc_array($name,$proc,args)]} then { # we found it, it has the number of arguments we are looking for... set result "1" } else { # nope, argument length mismatch. set result "0" } } else { # we found it, any amount of arguments is fine... set result "1" } } else { # not found in class... set result "0" # look for derived methods? if {$derived != "0"} then { # check for the proc in all the base classes referenced by this class... foreach this_name [array names local_base_array] { if {[string match "$name,*,name" $this_name] != "0"} then { set this_base_name [lindex [split $this_name ","] "1"] if {(([info exists local_proc_array($this_base_name,$proc,name)] != "0") && ([info exists local_proc_array($this_base_name,$proc,args)] != "0") && ([info exists local_proc_array($this_base_name,$proc,body)] != "0"))} then { # we've found it in a base class... set result "1" break } } } } } } else { set result "0" } } else { set result "0" } } else { set result "0" } } else { set result "0" } } else { set result "0" } return $result } ############################################################################### proc class_makeProcMaps { array_name name base } { return "0" } ############################################################################### proc class { name {body ""} } { global class_bases global class_names global class_procs global class_interfaces global class_variables global interface_names global interface_procs # # process "class" definition... # # NOTE: we will process "proc" and "variable" declarations and they will be # dispatched via our custom dispatcher. # # NOTE: every class definition must be a valid list. # if {[class_validName $name] != "0"} then { # don't allow duplicate class declarations if {[info exists class_names($name,name)] == "0"} then { # must have an even number of arguments... if {[llength $body] % "2" == "0"} then { # # initialize, there is no declaration error # set declaration_error "0" # # did we verify the entire declaration yet? # for {set verified "0"} {(($verified <= "1") && ($declaration_error == "0"))} {incr verified} { # class_output "processing class \"$name\" declaration, verified is \"$verified\"..." # always unset these... catch {unset temporary_class_procs} catch {unset temporary_class_variables} catch {unset temporary_class_interfaces} catch {unset temporary_class_bases} # # when in verify mode, setup the temporary arrays... # if {$verified == "0"} then { # array set temporary_class_procs {} # ok, we need the info... array set temporary_class_procs [array get class_procs] # array set temporary_class_variables {} # ok, we need the info... array set temporary_class_variables [array get class_variables] # array set temporary_class_interfaces {} # ok, we need the info... array set temporary_class_interfaces [array get class_interfaces] # array set temporary_class_bases {} # ok, we need the info... array set temporary_class_bases [array get class_bases] } set count [llength $body] set index "0" while {(($index < $count) && ($declaration_error == "0"))} { set this_body_part_type [lindex $body $index] # class_output "processing body part type \"$this_body_part_type\", declaration error is \"$declaration_error\"." # no string tolower, this is case sensitive switch -exact -- $this_body_part_type { "comment" { if {$index + "1" < $count} then { ################################################################## # this is basically a dummy body part, just advance to next one... ################################################################## # next body part... set index [expr {$index + "2"}] } else { class_output "bad comment declaration." set declaration_error "1" } } "interface" { if {$index + "1" < $count} then { # +0 == "interface" set this_interface_name [lindex $body [expr {$index + "1"}]] if {[class_validName $this_interface_name] != "0"} then { # make sure it's a currently defined interface... if {[info exists interface_names($this_interface_name,name)] != "0"} then { if {$verified != "0"} then { if {[info exists class_interfaces($name,$this_interface_name,name)] == "0"} then { set interface_exists "0" } else { set interface_exists "1" } } else { # check temp, to see if it's already used. if {[info exists temporary_class_interfaces($name,$this_interface_name,name)] == "0"} then { set interface_exists "0" } else { set interface_exists "1" } } if {$interface_exists == "0"} then { # assume good result, prove otherwise set have_procs "1" # set to something... just in case set this_proc_name "" # verify that we have all the procs required for this interface... foreach this_name [array names interface_procs] { # only check ones for this interface... if {[string match "$this_interface_name,*,name" $this_name] != "0"} then { set this_proc_name [lindex [split $this_name ","] "1"] # verify or define mode? if {$verified != "0"} then { set find_result [class_findProc class_bases class_procs $name "" $this_proc_name "-1" "1"] # make sure it's a valid base/derived class that it was found it... if {[llength $find_result] != "2"} then { # the proc is not found... set have_procs "0" class_output "class \"$name\" does not implement proc \"$this_proc_name\", required by interface \"$this_interface_name\"." set declaration_error "2" break } else { set this_class_name [lindex $find_result "0"] if {[llength $class_procs($this_class_name,$this_proc_name,args)] != [llength $interface_procs($this_interface_name,$this_proc_name,args)]} then { # must take same number of args... set have_procs "0" class_output "proc \"$this_proc_name\", required by interface \"$this_interface_name\", should take [llength $interface_procs($this_interface_name,$this_proc_name,args)] arguments." set declaration_error "3" break } } } else { set find_result [class_findProc temporary_class_bases temporary_class_procs $name "" $this_proc_name "-1" "1"] # make sure it's a valid base/derived class that it was found it... if {[llength $find_result] != "2"} then { # the proc is not found... set have_procs "0" class_output "class \"$name\" does not implement proc \"$this_proc_name\", required by interface \"$this_interface_name\"." set declaration_error "4" break } else { set this_class_name [lindex $find_result "0"] if {[llength $temporary_class_procs($this_class_name,$this_proc_name,args)] != [llength $interface_procs($this_interface_name,$this_proc_name,args)]} then { # must take same number of args... set have_procs "0" class_output "proc \"$this_proc_name\", required by interface \"$this_interface_name\", should take [llength $interface_procs($this_interface_name,$this_proc_name,args)] arguments." set declaration_error "5" break } } } } } if {$have_procs != "0"} then { if {$verified != "0"} then { # only actually add proc when not running in verification mode... set class_interfaces($name,$this_interface_name,name) $name set class_interfaces($name,$this_interface_name,interface) $this_interface_name } else { # add to temp, so we know it's already used. set temporary_class_interfaces($name,$this_interface_name,name) $name set temporary_class_interfaces($name,$this_interface_name,interface) $this_interface_name } # next body part... set index [expr {$index + "2"}] } } else { class_output "interface \"$this_interface_name\" already declared." set declaration_error "6" } } else { class_output "class \"$name\" references non-existant interface \"$this_interface_name\"." set declaration_error "7" } } else { class_output "invalid interface name \"$this_interface_name\"." set declaration_error "8" } } else { class_output "bad interface declaration." set declaration_error "9" } } "proc" { # proc name {args} {body} if {$index + "3" < $count} then { # +0 == "proc" set this_proc_name [lindex $body [expr {$index + "1"}]] set this_proc_args [lindex $body [expr {$index + "2"}]] set this_proc_body [lindex $body [expr {$index + "3"}]] if {[class_validName $this_proc_name] != "0"} then { if {$verified != "0"} then { if {[class_hasProc class_bases class_procs $name $this_proc_name "-1" "0"] == "0"} then { set proc_exists "0" } else { set proc_exists "1" } } else { # check temp, to see if it's already used. if {[class_hasProc temporary_class_bases temporary_class_procs $name $this_proc_name "-1" "0"] == "0"} then { set proc_exists "0" } else { set proc_exists "1" } } if {$proc_exists == "0"} then { if {$verified != "0"} then { # only actually add proc when not running in verification mode... set class_procs($name,$this_proc_name,name) $this_proc_name set class_procs($name,$this_proc_name,args) $this_proc_args set class_procs($name,$this_proc_name,body) $this_proc_body } else { # add to temp, so we know it's already used. set temporary_class_procs($name,$this_proc_name,name) $this_proc_name set temporary_class_procs($name,$this_proc_name,args) $this_proc_args set temporary_class_procs($name,$this_proc_name,body) $this_proc_body } # next body part... set index [expr {$index + "4"}] } else { class_output "proc \"$this_proc_name\" already declared." set declaration_error "10" } } else { class_output "invalid proc name \"$this_proc_name\"." set declaration_error "11" } } else { class_output "bad proc declaration." set declaration_error "12" } } "variable" { # variable name if {$index + "1" < $count} then { # +0 == "variable" set this_variable_name [lindex $body [expr {$index + "1"}]] if {[class_validName $this_variable_name] != "0"} then { if {$verified != "0"} then { if {[info exists class_variables($name,$this_variable_name,name)] == "0"} then { set variable_exists "0" } else { set variable_exists "1" } } else { # check temp, to see if it's already used. if {[info exists temporary_class_variables($name,$this_variable_name,name)] == "0"} then { set variable_exists "0" } else { set variable_exists "1" } } if {$variable_exists == "0"} then { if {$verified != "0"} then { # only actually add variable when not running in verification mode... set class_variables($name,$this_variable_name,name) $this_variable_name } else { # add to temp, so we know it's already used. set temporary_class_variables($name,$this_variable_name,name) $this_variable_name } # next body part... set index [expr {$index + "2"}] } else { class_output "variable \"$this_variable_name\" already declared." set declaration_error "13" } } else { class_output "invalid variable name \"$this_variable_name\"." set declaration_error "14" } } else { class_output "bad variable declaration." set declaration_error "15" } } "base" { if {$index + "1" < $count} then { # +0 == "base" set this_base_name [lindex $body [expr {$index + "1"}]] if {[class_validName $this_base_name] != "0"} then { # make sure it's a currently defined class... if {[info exists class_names($this_base_name,name)] != "0"} then { if {$verified != "0"} then { if {[info exists class_bases($name,$this_base_name,name)] == "0"} then { set base_exists "0" } else { set base_exists "1" } } else { # check temp, to see if it's already used. if {[info exists temporary_class_bases($name,$this_base_name,name)] == "0"} then { set base_exists "0" } else { set base_exists "1" } } if {$base_exists == "0"} then { if {$verified != "0"} then { # only actually add base when not running in verification mode... if {[class_makeProcMaps class_procmaps $name $this_base_name] == "0"} then { set class_bases($name,$this_base_name,name) $name set class_bases($name,$this_base_name,base) $this_base_name # next body part... set index [expr {$index + "2"}] } else { class_output "could not add base class \"$this_base_name\" procs to class \"$name\"." set declaration_error "16" } } else { # add to temp, so we know it's already used. if {[class_makeProcMaps temporary_class_procmaps $name $this_base_name] == "0"} then { set temporary_class_bases($name,$this_base_name,name) $name set temporary_class_bases($name,$this_base_name,base) $this_base_name # next body part... set index [expr {$index + "2"}] } else { class_output "could not add base class \"$this_base_name\" procs to class \"$name\"." set declaration_error "17" } } } else { class_output "class \"$name\" already references base class \"$this_base_name\"." set declaration_error "18" } } else { class_output "class \"$name\" references non-existant base class \"$this_base_name\"." set declaration_error "19" } } else { class_output "invalid base class name \"$this_base_name\"." set declaration_error "20" } } else { class_output "bad base class declaration." set declaration_error "21" } } default { # fail, bad declaration type class_output "bad declaration type \"$this_body_part_type\"." set declaration_error "22" } } } } if {$declaration_error == "0"} then { set class_names($name,name) $name } else { # invalid syntax... # raise error here... class_output "class \"$name\" declaration error #$declaration_error." } } else { # invalid syntax... # raise error here... class_output "class \"$name\" declaration error, even number of arguments required." } } else { # class already defined.. # raise error here... class_output "class \"$name\" already declared." } } else { # invalid syntax... # raise error here... class_output "invalid class name \"$name\"." } } ############################################################################### proc object_destroy { object args } { global class_bases global class_objects global class_procs if {[class_validHandle $object] != "0"} then { if {[class_validObject $object] != "0"} then { if {$class_objects($object,constructed) != "0"} then { # # call destructor if necessary... # set destructor [namespace eval $object namespace which -command "destructor"] if {$destructor != ""} then { # set default result... set destructor_error "Zero returned from destructor." if {[catch {set result [eval $destructor $object $args]} destructor_error] != "0"} then { # failed... set result "0" } } else { # skipped... set result "1" } } else { # never fully constructed, skip it. set result "1" } if {$result != "0"} then { # get the object's name... set name $class_objects($object,name) # we need to do this here so that all procs are available later... foreach this_base [array names class_bases] { # check for bases of our object... if {[string match "$name,*,name" $this_base] != "0"} then { set this_base_name [lindex [split $this_base ","] "1"] # delete all command aliases... foreach this_proc [array names class_procs] { if {[string match "$this_base_name,*,name" $this_proc] != "0"} then { set this_proc_name [lindex [split $this_proc ","] "1"] namespace eval $object.$this_base_name [list interp alias {} [join [list $object.$this_base_name $this_proc_name] "::"] {}] } } # delete base object namespaces... namespace delete $object.$this_base_name } } # remove all procs and vars for object and the namespace itself namespace delete $object # unset "object" storage... unset class_objects($object,constructed) unset class_objects($object,object) unset class_objects($object,name) # remove global object dispatch proc rename $object "" } else { class_output "cannot destroy object \"$object\", destructor failed with error `` $destructor_error ''." } } else { class_output "cannot destroy object \"$object\", not found." } } else { class_output "invalid object \"$object\"." } } ############################################################################### proc interface_destroy { name } { global interface_names global interface_procs if {[class_validName $name] != "0"} then { if {[info exists interface_names($name,name)] != "0"} then { if {[llength [interface_classes $name]] == "0"} then { foreach this_name [array names interface_procs] { # remove all for this class... if {[string match "$name,*" $this_name] != "0"} then { unset interface_procs($this_name) } } unset interface_names($name,name) } else { class_output "cannot destroy interface \"$name\", objects still active." } } else { class_output "cannot destroy interface \"$name\", not found." } } else { class_output "cannot destroy interface \"$name\", invalid name." } } ############################################################################### proc class_destroy { name } { global class_bases global class_names global class_procs global class_variables global class_interfaces if {[class_validName $name] != "0"} then { if {[info exists class_names($name,name)] != "0"} then { if {[llength [base_classes $name]] == "0"} then { if {[llength [class_objects $name]] == "0"} then { foreach this_name [array names class_procs] { # remove all for this class... if {[string match "$name,*" $this_name] != "0"} then { unset class_procs($this_name) } } foreach this_name [array names class_variables] { # remove all for this class... if {[string match "$name,*" $this_name] != "0"} then { unset class_variables($this_name) } } foreach this_name [array names class_interfaces] { # remove all for this class... if {[string match "$name,*" $this_name] != "0"} then { unset class_interfaces($this_name) } } foreach this_name [array names class_bases] { # remove all for this class... if {[string match "$name,*" $this_name] != "0"} then { unset class_bases($this_name) } } unset class_names($name,name) } else { class_output "cannot destroy class \"$name\", objects still active." } } else { class_output "cannot destroy class \"$name\", it is being used as a base class." } } else { class_output "cannot destroy class \"$name\", not found." } } else { class_output "cannot destroy class \"$name\", invalid name." } } ############################################################################### proc object { name args } { global class_bases global class_names global class_objects global class_procs if {[class_validName $name] != "0"} then { if {[info exists class_names($name,name)] != "0"} then { set this_object_name [class_generateName "$name.object."] if {[class_validObject $this_object_name] == "0"} then { set class_objects($this_object_name,name) $name set class_objects($this_object_name,object) $this_object_name foreach this_name [array names class_variables] { # only variable names for this class... if {[string match "$name,*,name" $this_name] != "0"} then { namespace eval $this_object_name variable $class_variables($name,$this_name,name) } } # create object dispatch proc... proc $this_object_name { proc args } [concat class_dispatch $this_object_name \$proc \$args] # we need to do this here so that all procs are available later... foreach this_name [array names class_procs] { if {[string match "$name,*,name" $this_name] != "0"} then { set this_proc_name [lindex [split $this_name ","] "1"] if {[class_hasProc class_bases class_procs $name $this_proc_name "-1" "0"] != "0"} then { # not a typo, set it again from real array set this_proc_name $class_procs($name,$this_proc_name,name) set this_proc_args $class_procs($name,$this_proc_name,args) set this_proc_body $class_procs($name,$this_proc_name,body) # fixup local vars and predefined vars, etc # added $me for rohan... :) set this_proc_body "[class_variableDeclarations $name]\nset base $name\nset name $name\nset this $this_object_name\nset me $this_object_name\n\n$this_proc_body" namespace eval $this_object_name [list proc $this_proc_name $this_proc_args $this_proc_body] } } } # we need to do this here so that all procs are available later... foreach this_base [array names class_bases] { if {[string match "$name,*,base" $this_base] != "0"} then { set this_base_name [lindex [split $this_base ","] "1"] foreach this_proc [array names class_procs] { if {[string match "$this_base_name,*,name" $this_proc] != "0"} then { set this_proc_name [lindex [split $this_proc ","] "1"] if {[class_hasProc class_bases class_procs $this_base_name $this_proc_name "-1" "0"] != "0"} then { # not a typo, set it again from real array set this_proc_name $class_procs($this_base_name,$this_proc_name,name) set this_proc_args $class_procs($this_base_name,$this_proc_name,args) set this_proc_body $class_procs($this_base_name,$this_proc_name,body) # fixup local vars and predefined vars, etc # added $me for rohan... :) set this_proc_body "[class_variableDeclarations $this_base_name]\nset base $this_base_name\nset name $name\nset this $this_object_name\nset me $this_object_name\n\n$this_proc_body" # create the proc in the object's own namespace... namespace eval $this_object_name.$this_base_name [list proc $this_proc_name $this_proc_args $this_proc_body] # create an alias for the derived method in the object's own namespace... namespace eval $this_object_name.$this_base_name [list interp alias {} [join [list $this_object_name.$this_base_name $this_proc_name] "::"] {} $this_proc_name] } } } } } # # call constructor if necessary... # set constructor [namespace eval $this_object_name namespace which -command "constructor"] if {$constructor != ""} then { # set default result... set constructor_error "Zero returned from constructor." if {[catch {set result [eval $constructor $this_object_name $args]} constructor_error] != "0"} then { # failed... set class_objects($this_object_name,constructed) "0" set result "0" } else { set class_objects($this_object_name,constructed) "1" } } else { # skipped... set class_objects($this_object_name,constructed) "1" set result "1" } if {$result != "0"} then { # return object "handle" set result $this_object_name } else { # # failed constructor or other serious problem... # class_output "cannot create object \"$object\", constructor failed with error `` $constructor_error ''." object_destroy $this_object_name set result "" } } else { class_output "cannot create object, name generation error (this should not happen)." set result "" } } else { class_output "cannot create object, class \"$name\" not found." set result "" } } else { class_output "cannot create object, invalid class \"$name\"." set result "" } return $result } ############################################################################### proc object_class { object } { global class_objects if {[class_validHandle $object] != "0"} then { if {[class_validObject $object] != "0"} then { set result $class_objects($object,name) } else { set result "" } } else { set result "" } return $result } ############################################################################### proc interface_classes { name } { global class_interfaces # # return a list of classes implementing one or more interfaces # set result "" foreach this_name [array names class_interfaces] { # only names if {[string match "*,interface" $this_name] != "0"} then { # only the one(s) we want... if {[string match $name $class_interfaces($this_name)] != "0"} then { set this_class_name [lindex [split $this_name ","] "0"] set this_interface_name [lindex [split $this_name ","] "1"] # append to result list lappend result $class_interfaces($this_class_name,$this_interface_name,name) } } } return $result } ############################################################################### proc class_interfaces { name } { global class_interfaces # # return a list of interfaces for one or more classes matching "name" # set result "" foreach this_name [array names class_interfaces] { # only names if {[string match "*,name" $this_name] != "0"} then { # only the one(s) we want... if {[string match $name $class_interfaces($this_name)] != "0"} then { set this_class_name [lindex [split $this_name ","] "0"] set this_interface_name [lindex [split $this_name ","] "1"] # append to result list lappend result $class_interfaces($this_class_name,$this_interface_name,interface) } } } return $result } ############################################################################### proc base_classes { name } { global class_bases # # return a list of classes that use the classes matching "name" as a base. # set result "" foreach this_name [array names class_bases] { # only names if {[string match "*,base" $this_name] != "0"} then { # only the one(s) we want... if {[string match $name $class_bases($this_name)] != "0"} then { set this_class_name [lindex [split $this_name ","] "0"] set this_base_name [lindex [split $this_name ","] "1"] # append to result list lappend result $class_bases($this_class_name,$this_base_name,name) } } } return $result } ############################################################################### proc class_bases { name } { global class_bases # # return a list of active bases for one or more classes matching "name" # set result "" foreach this_name [array names class_bases] { # only names if {[string match "*,name" $this_name] != "0"} then { # only the one(s) we want... if {[string match $name $class_bases($this_name)] != "0"} then { set this_class_name [lindex [split $this_name ","] "0"] set this_base_name [lindex [split $this_name ","] "1"] # append to result list lappend result $class_bases($this_class_name,$this_base_name,base) } } } return $result } ############################################################################### proc class_objects { name } { global class_objects # # return a list of active objects for one or more classes matching "name" # set result "" foreach this_name [array names class_objects] { # only names if {[string match "*,name" $this_name] != "0"} then { # only the one(s) we want... if {[string match $name $class_objects($this_name)] != "0"} then { # get just the name portion set this_object_name [lindex [split $this_name ","] "0"] # append to result list lappend result $class_objects($this_object_name,object) } } } return $result } ############################################################################### proc class_initialize {} { # # initialize global variables... # uplevel "#0" { catch {unset class_names} array set class_names {} catch {unset class_procs} array set class_procs {} catch {unset class_variables} array set class_variables {} catch {unset class_objects} array set class_objects {} catch {unset class_interfaces} array set class_interfaces {} catch {unset class_bases} array set class_bases {} catch {unset interface_names} array set interface_names {} catch {unset interface_procs} array set interface_procs {} } return "0" } ############################################################################### proc class_terminate {} { # # unset global variables... # uplevel "#0" { catch {unset class_bases} catch {unset class_names} catch {unset class_procs} catch {unset class_variables} catch {unset class_objects} catch {unset class_interfaces} catch {unset interface_names} catch {unset interface_procs} } return "0" } ############################################################################### class_initialize # // end of file
Tests Source File (class_test.tcl)
# for Tk (windows only?)
catch {console show}
# bring in the class/object related commands...
source [file join [file dirname [info script]] "class.tcl"]
###############################################################################
proc testBadDeclareClass {} {
class badClass {
variable x
proc badProc {args}
}
class badClass2 {
variable x
proc badProc {args} {}
proc badProc {} {}
}
class badClass3 {
variable x
variable x
proc badProc {args} {}
}
class badClass4 {
variable %x
proc badProc {args} {}
}
class badClass5 {
variable x
proc %badProc {args} {}
}
class badClass6 {
variable x
invalidItem y
proc badProc {args} {}
}
class badClass7 {
variable
}
class %%%badClass8 {
variable x
}
class badClass9 {
variable x
proc proc1 {} {}
interface testInterface
}
class badClass10 {
proc proc1 {} {}
proc proc2 {} {}
proc proc3 {a} {}
interface testInterface
}
}
###############################################################################
proc testBadObjectDestroy {} {
object_destroy thisObjectNotFound
}
###############################################################################
proc testBadClassDestroy {} {
class_destroy thisClassNotFound
class_destroy %%thisClassInvalidName
}
###############################################################################
proc testBadObjectCreate {} {
set gz [object thisClassNotFound]
set gz [object %%thisClassInvalidName]
}
###############################################################################
proc testBadInUseClassDestroy {} {
class_destroy testClass
class_destroy testClass2
class_destroy testClass3
}
###############################################################################
proc testBadInUseInterfaceDestroy {} {
interface_destroy emptyInterface
interface_destroy testInterface
}
###############################################################################
proc testGoodDeclareInterface {} {
# declare empty interface
interface emptyInterface
# declare a test interface
interface testInterface {
comment {
# this is a comment section...
# everything except unbalanced braces should be fine.
}
proc proc1 {} {
class_output "call to interface proc (this should NOT happen)!"
}
proc proc2 {} {
class_output "call to interface proc (this should NOT happen)!"
}
proc proc3 {a b c} {
class_output "call to interface proc (this should NOT happen)!"
}
}
}
###############################################################################
proc testGoodDeclareClass {} {
# make a dummy class...
class emptyClass
class testClass {
variable x
variable y
variable z
variable array_variable
proc constructor { object args } { class_output "NEW: [info level [info level]]"; return "1" }
proc destructor { object args } { class_output "DELETE: [info level [info level]]"; return "1" }
proc test0a {a} { class_output "TEST: [info level [info level]]"; set x $a }
proc test0b {b} { class_output "TEST: [info level [info level]]"; set y $b }
proc test1 {} { class_output "TEST: [info level [info level]]"; return $x.$y }
proc test2 {a} { class_output "TEST: [info level [info level]]"; return [test0a $a] }
proc test2a {a} {
class_output "TEST: [info level [info level]]"
# using %this% is DEPRECATED
$this test0a $a; return $x
}
proc test2b {a} { class_output "TEST: [info level [info level]]"; return [test3] }
proc test2c {a} { class_output "TEST: [info level [info level]]"; $this test0a $a; return $x }
proc test3 {} { class_output "TEST: [info level [info level]]"; return "foo" }
proc test4 {a} { class_output "TEST: [info level [info level]]"; return $a }
proc test5 {a b c} { class_output "TEST: [info level [info level]]"; class_output "a = $a"; class_output "b = $b"; class_output "c = $c" }
proc test6 {a b} { class_output "TEST: [info level [info level]]"; error $a }
proc test7 {} { class_output "TEST: [info level [info level]]"; return $name }
proc test8 {} { class_output "TEST: [info level [info level]]"; return $this }
proc test9 {} {
class_output "TEST: [info level [info level]]"
set array_variable(1) "element 1"
set array_variable(2) "element 2"
set array_variable(3) "element 3"
return [array names array_variable]
}
proc test10 {} {
class_output "TEST: [info level [info level]]"
return [array names array_variable]
}
comment {
# this is a comment section...
# everything except unbalanced braces should be fine.
}
}
class testClass2 {
proc constructor { object args } { class_output "NEW: [info level [info level]]"; return "1" }
proc destructor { object args } { class_output "DELETE: [info level [info level]]"; return "1" }
proc test1 {} { class_output "TEST: [info level [info level]]"; return "$name.$this" }
proc test2 {} { class_output "TEST: [info level [info level]]"; return $x }
proc test3 {} { class_output "TEST: [info level [info level]]"; set x "\["; return [eval $x] }
}
class testClass3 {
proc constructor { object args } { class_output "NEW: [info level [info level]]"; return "1" }
proc destructor { object args } { class_output "DELETE: [info level [info level]]"; return "1" }
proc proc1 {} {class_output "TEST: [info level [info level]]"; class_output "CALL: $this.testInterface.proc1"}
proc proc2 {} {class_output "TEST: [info level [info level]]"; class_output "CALL: $this.testInterface.proc2"}
proc proc3 {a b c} {class_output "TEST: [info level [info level]]"; class_output "CALL: $this.testInterface.proc3($a $b $c)"}
interface emptyInterface
interface testInterface
}
class testClass4 {
variable notAccessible
comment {
# we can access this variable through the namespace created for us by the [object] command.
}
}
}
###############################################################################
proc testInterfaceIntrospection { name } {
class_output "interface \"$name\" classes are \{[interface_classes $name]\}."
}
###############################################################################
proc testClassIntrospection { name } {
class_output "class \"$name\" interfaces are \{[class_interfaces $name]\}."
class_output "class \"$name\" base classes are \{[class_bases $name]\}."
}
###############################################################################
proc testGoodObjectCreate {} {
global gx
set gx(1) [object "testClass"]
set gx(2) [object "testClass2"]
set gx(3) [object "testClass3" list of arguments.]
set gx(4) [object "testClass4"]
}
###############################################################################
proc testGoodObjectDestroy {} {
global gx
object_destroy $gx(1)
object_destroy $gx(2)
object_destroy $gx(3) list of arguments.
object_destroy $gx(4)
class_output "namespace $gx(1) exists: [namespace exists $gx(1)]"
class_output "namespace $gx(2) exists: [namespace exists $gx(2)]"
class_output "namespace $gx(3) exists: [namespace exists $gx(3)]"
class_output "namespace $gx(4) exists: [namespace exists $gx(4)]"
# clear object ref variables
unset gx
}
###############################################################################
proc testGoodClassDestroy {} {
class_destroy testClass
class_destroy testClass2
class_destroy testClass3
class_destroy testClass4
class_destroy emptyClass
}
###############################################################################
proc testGoodInterfaceDestroy {} {
interface_destroy emptyInterface
interface_destroy testInterface
}
###############################################################################
proc testGoodClass1Procs {} {
global gx
global gy
set gy [$gx(1) test0a "123"]
class_output "$gy\n"
set gy [$gx(1) test0b "456"]
class_output "$gy\n"
set gy [$gx(1) test1]
class_output "$gy\n"
set gy [$gx(1) test2 "foobar"]
class_output "$gy\n"
set gy [$gx(1) test2a "foobar"]
class_output "$gy\n"
set gy [$gx(1) test2b "foobar"]
class_output "$gy\n"
set gy [$gx(1) test2c "foobar"]
class_output "$gy\n"
set gy [$gx(1) test3]
class_output "$gy\n"
set gy [$gx(1) test4 {a b c 1 2 3}]
class_output "$gy\n"
set gy [$gx(1) test5 {a b c 1 2 3} {a 2 2 b} 234234]
class_output "$gy\n"
catch {$gx(1) test6 "this is an error." "huh?"} gy
class_output "$gy\n"
set gy [$gx(1) test7]
class_output "$gy\n"
set gy [$gx(1) test8]
class_output "$gy\n"
set gy [$gx(1) test9]
class_output "$gy\n"
set gy [$gx(1) test10]
class_output "$gy\n"
set gy [$gx(1) testNotFound]
class_output "$gy\n"
}
###############################################################################
proc testGoodClass2Procs {} {
global gx
global gy
set gy [$gx(2) test1]
class_output "$gy\n"
catch {$gx(2) test2} gy
class_output "$gy\n"
catch {$gx(2) test3} gy
class_output "$gy\n"
}
###############################################################################
proc testGoodClass3Procs {} {
global gx
global gy
set gy [$gx(3) proc1]
class_output "$gy\n"
set gy [$gx(3) proc2]
class_output "$gy\n"
set gy [$gx(3) proc3 "one" "abc" "123"]
class_output "$gy\n"
}
###############################################################################
proc testGoodClass4Variable {} {
global gx
class_output "TEST: [info level [info level]]"
namespace eval $gx(4) [list set notAccessible "this is the variable."]
class_output "variable for testClass4: [set $gx(4)::notAccessible]\n"
}
###############################################################################
proc testGoodReferences {} {
class_output "interface myInterface* classes are \{[interface_classes myInterface*]\}."
class_output "class testClass objects are \{[class_objects testClass]\}."
class_output "class testClass* objects are \{[class_objects testClass*]\}."
}
###############################################################################
proc testGoodBasedOn {} {
global gx
class_output "object \"$gx(1)\" is based on class \"[object_class $gx(1)]\"."
class_output "object \"$gx(2)\" is based on class \"[object_class $gx(2)]\"."
class_output "object \"$gx(3)\" is based on class \"[object_class $gx(3)]\"."
class_output "object \"$gx(4)\" is based on class \"[object_class $gx(4)]\"."
}
###############################################################################
proc testCleanup {} {
uplevel "#0" {
class_output "class names elements remaining (should be zero): [llength [array names class_names]]"
class_output "class objects elements remaining (should be zero): [llength [array names class_objects]]"
class_output "class procs elements remaining (should be zero): [llength [array names class_procs]]"
class_output "class variables elements remaining (should be zero): [llength [array names class_variables]]"
class_output "class interfaces elements remaining (should be zero): [llength [array names class_interfaces]]"
class_output "class bases elements remaining (should be zero): [llength [array names class_bases]]"
class_output "interface names elements remaining (should be zero): [llength [array names interface_names]]"
class_output "interface procs elements remaining (should be zero): [llength [array names interface_procs]]"
}
}
###############################################################################
# Now, we will run the actual tests we want to see...
#
# NOTE: for the time being, you should manually "eye" the results. ;-)
#
###############################################################################
testGoodDeclareInterface
# testBadDeclareClass
# testBadObjectDestroy
# testBadClassDestroy
# testBadObjectCreate
testGoodDeclareClass
testClassIntrospection testClass
testClassIntrospection testClass3
testClassIntrospection testClass*
testInterfaceIntrospection emptyInterface
testInterfaceIntrospection testInterface
testGoodObjectCreate
testGoodReferences
testGoodBasedOn
testBadInUseClassDestroy
testBadInUseInterfaceDestroy
testGoodClass1Procs
testGoodClass2Procs
testGoodClass3Procs
testGoodClass4Variable
testGoodObjectDestroy
testGoodClassDestroy
testGoodInterfaceDestroy
testCleanup
# // end of fileMore Tests Source File (class_test2.tcl)
# for Tk (windows only?)
catch {console show}
# bring in the class/object related commands...
source [file join [file dirname [info script]] "class.tcl"]
###############################################################################
proc testGoodDeclareInterface2 {} {
# declare empty interface
interface emptyInterface2
# declare a test interface
interface testInterface2 {
proc proc1 {} {
class_output "call to interface proc (this should NOT happen)!"
}
proc proc2 {} {
class_output "call to interface proc (this should NOT happen)!"
}
proc proc3 {a b c} {
class_output "call to interface proc (this should NOT happen)!"
}
}
}
###############################################################################
proc testGoodDeclareClass2 {} {
class baseClass {
interface emptyInterface2
variable x
variable w
proc proc1 {} { class_output "TEST: [info level [info level]]"; return $x }
proc baseMethod {a} { class_output "TEST: [info level [info level]]"; set w $a; set x $a; set y $a; set z $a; return $x }
proc baseMethod3 {} { class_output "TEST: [info level [info level]]"; set x "[info exists w] [info exists x] [info exists y] [info exists z]"; return $x }
}
class baseClass2 {
interface emptyInterface2
variable x
variable y
proc proc2 {} { class_output "TEST: [info level [info level]]"; return $x }
proc baseMethod2 {a} { class_output "TEST: [info level [info level]]"; set w $a; set x $a; set y $a; set z $a; return $x }
proc baseMethod4 {} { class_output "TEST: [info level [info level]]"; set x "[info exists w] [info exists x] [info exists y] [info exists z]"; return $x }
}
class derivedClass {
interface emptyInterface2
base baseClass
base baseClass2
variable x
variable z
proc proc3 {a b c} { class_output "TEST: [info level [info level]]"; return [list $a $b $c $x] }
proc derivedMethod {a} { class_output "TEST: [info level [info level]]"; set w $a; set x $a; set y $a; set z $a; return $x }
proc derivedMethod2 {} { class_output "TEST: [info level [info level]]"; set x "[info exists w] [info exists x] [info exists y] [info exists z]"; return $x }
interface testInterface2
}
}
###############################################################################
proc testGoodObjectDestroy2 {} {
global gx2
object_destroy $gx2(5)
class_output "namespace $gx2(5) exists: [namespace exists $gx2(5)]"
# clear object ref variables
unset gx2
}
###############################################################################
proc testGoodObjectCreate2 {} {
global gx2
set gx2(5) [object "derivedClass"]
}
###############################################################################
proc testGoodClassDestroy2 {} {
class_destroy derivedClass
class_destroy baseClass2
class_destroy baseClass
}
###############################################################################
proc testGoodInterfaceDestroy2 {} {
interface_destroy emptyInterface2
interface_destroy testInterface2
}
###############################################################################
proc testGoodClass1Procs2 {} {
global gx2
global gy2
# test first base method...
set gy2 [$gx2(5) baseMethod "this is cool."]
class_output "TEST_2_1: $gy2"
# test error handling...
set gy2 ""
catch {$gx2(5) baseMethod "this is cool." "not cool."} gy2
class_output "TEST_2_2: $gy2"
# test second base method...
set gy2 [$gx2(5) baseMethod2 "this is cool."]
class_output "TEST_2_3: $gy2"
# test error handling...
set gy2 ""
catch {$gx2(5) baseMethod2 "this is cool." "not cool."} gy2
class_output "TEST_2_4: $gy2"
# test first method in derived class...
set gy2 [$gx2(5) derivedMethod "this is cool."]
class_output "TEST_2_5: $gy2"
# test error handling...
set gy2 ""
catch {$gx2(5) derivedMethod "this is cool." "not cool."} gy2
class_output "TEST_2_6: $gy2"
# test variable handling...
set gy2 [$gx2(5) baseMethod3]
class_output "TEST_2_7: $gy2"
set gy2 [$gx2(5) baseMethod4]
class_output "TEST_2_8: $gy2"
set gy2 [$gx2(5) derivedMethod2]
class_output "TEST_2_9: $gy2"
set gy2 [$gx2(5) proc1]
class_output "TEST_2_10: $gy2"
set gy2 [$gx2(5) proc2]
class_output "TEST_2_11: $gy2"
set gy2 [$gx2(5) proc3 ABC DEF GHI]
class_output "TEST_2_12: $gy2"
}
###############################################################################
proc testCleanup2 {} {
uplevel "#0" {
class_output "class names elements remaining (should be zero): [llength [array names class_names]]"
class_output "class objects elements remaining (should be zero): [llength [array names class_objects]]"
class_output "class procs elements remaining (should be zero): [llength [array names class_procs]]"
class_output "class variables elements remaining (should be zero): [llength [array names class_variables]]"
class_output "class interfaces elements remaining (should be zero): [llength [array names class_interfaces]]"
class_output "class bases elements remaining (should be zero): [llength [array names class_bases]]"
class_output "interface names elements remaining (should be zero): [llength [array names interface_names]]"
class_output "interface procs elements remaining (should be zero): [llength [array names interface_procs]]"
}
}
###############################################################################
# Now, we will run the actual tests we want to see...
#
# NOTE: for the time being, you should manually "eye" the results. ;-)
#
###############################################################################
testGoodDeclareInterface2
testGoodDeclareClass2
testGoodObjectCreate2
testGoodClass1Procs2
testGoodObjectDestroy2
testGoodClassDestroy2
testGoodInterfaceDestroy2
testCleanup2
# // end of fileVersion History