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:

   * "classes" definitions or "what procs and variables do all instances of this class have?"
   * "objects" or "an instance of a class."
   * Now supports transparent usage of class variables and procs from inside the class.
   * "interfaces" or "what procs are required to implement this interface?"
   * "comment" blocks inside class and interface declarations.
   * "single inheritance" or "procs from this other class are now in this class."
   * "multiple inheritance" or "procs from these other classes are now in this class."
   * "constructors" and "destructors", that can take parameters and can prevent the object from being created/destroyed.

----

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 <joe@mistachkin.com>
 #   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.61"
 
 ###############################################################################
 
 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") && ($declaration_error == "0"))} {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 file

----

----

More 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 file

----

 Version History

   * 19/Nov/2002 Version 1.00 -- initial release
   * 19/Nov/2002 Version 1.20 -- added transparent access to class variables
   * -- streamlined some of the code
   * -- more comprehensive cleanup of variables, procs, and namespaces
   * 20/Nov/2002 Version 1.25 -- more robust handling of invalid class declarations
   * -- added tests for arrays inside classes
   * 20/Nov/2002 Version 1.30 -- more argument validation
   * -- added more tests dealing with invalid class declarations
   * -- added class_objects proc to return a list of active objects for a class
   * 20/Nov/2002 Version 1.31 -- fixed error handling for a certain test case involving bad class declarations
   * 20/Nov/2002 Version 1.32 -- fixed problem preventing multiple matches in class_objects
   * 22/Nov/2002 Version 1.40 -- added support for interfaces
   * -- added support for comment blocks inside classes and interfaces
   * -- cleaned up and organized tests
   * -- changed some error messages
   * -- other miscellaneous changes
   * 13/Mar/2003 Version 1.60 -- added support for inheritance, single and multiple
   * -- a lot of cleanup and reorganization
   * -- added support for implementing an interface using base classes
   * -- added more introspection features
   * -- added support for parameterized constructors/destructors (can stop creation/destruction)
   * 13/Mar/2003 Version 1.61 -- corrected loop invariant for interface definitions

----

[Category Object Orientation]