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 # # A simple implementation. # # Copyright (c) 2002 by Joe Mistachkin. All rights reserved. # # written by: Joe Mistachkin <[email protected]> # created on: 11/18/2002 # ############################################################################### # # 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.31" ############################################################################### 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_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_name [class_variableNameList $name] { append result "variable $this_variable_name\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_names global class_procs global class_variables global class_objects # make sure we have a valid object... if {[info exists class_objects($object,object)] != "0"} then { # make sure it's linked to a valid class... if {[info exists class_names($class_objects($object,name),name)] != "0"} then { # make sure it's a valid proc... if {(([info exists class_procs($class_objects($object,name),$proc,name)] != "0") && ([info exists class_procs($class_objects($object,name),$proc,args)] != "0") && ([info exists class_procs($class_objects($object,name),$proc,body)] != "0"))} then { # "unpack" arguments into the array... array set argument_array {} set argument_name_list [class_argumentNameList argument_array [llength $class_procs($class_objects($object,name),$proc,args)]] 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 $object $class_objects($object,name).$class_procs($class_objects($object,name),$proc,name) $argument_value_list namespace eval $object $class_procs($class_objects($object,name),$proc,name) $argument_value_list } else { puts stdout "proc \"$object.$proc\" not found." } } else { puts stdout "object linked to invalid class \"$class_objects($object,name)\"." } } else { puts stdout "invalid object \"$object\"." } } proc class { name {body ""} } { global class_names global class_procs global class_variables # # process "class" definition... # # NOTE: we will process "proc" and "variable" declarations and they will be # dispatched via our custom dispatcher. # # must have an even number of arguments... if {[class_validName $name] != "0"} then { # don't allow duplicate class declarations if {[info exists class_names($name,name)] == "0"} then { if {[llength $body] % "2" == "0"} then { # # initialize, there is no declaration error # set class_error "0" # # did we verify the entire declaration yet? # for {set verified "0"} {$verified <= "1"} {incr verified} { # puts stdout "processing class \"$name\" declaration, verified is \"$verified\"..." array set temporary_class_procs {} array set temporary_class_variables {} set count [llength $body] set index "0" while {(($index < $count) && ($class_error == "0"))} { set this_body_part_type [lindex $body $index] # puts stdout "processing body part type \"$this_body_part_type\", class error is \"$class_error\"." # no string tolower, this is case sensitive switch -exact -- $this_body_part_type { "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 class_procs($name,$this_proc_name,name)] == "0") && ([info exists class_procs($name,$this_proc_name,args)] == "0") && ([info exists class_procs($name,$this_proc_name,body)] == "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_class_procs($name,$this_proc_name,name)] == "0") && ([info exists temporary_class_procs($name,$this_proc_name,args)] == "0") && ([info exists temporary_class_procs($name,$this_proc_name,body)] == "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 { puts stdout "proc \"$this_proc_name\" already defined." set class_error "1" } } else { puts stdout "invalid proc name \"$this_proc_name\"." set class_error "2" } } else { puts stdout "bad proc declaration." set class_error "3" } } "variable" { # variable name if {$index + "1" < $count} then { # +0 == "proc" 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 { puts stdout "variable \"$this_variable_name\" already defined." set class_error "4" } } else { puts stdout "invalid variable name \"$this_variable_name\"." set class_error "5" } } else { puts stdout "bad variable declaration." set class_error "6" } } default { # fail, bad declaration type puts stdout "bad declaration type \"$this_body_part_type\"." set class_error "7" } } } } if {$class_error == "0"} then { set class_names($name,name) $name } else { # invalid syntax... # raise error here... puts stdout "class \"$name\" definition error #$class_error." } } else { # invalid syntax... # raise error here... puts stdout "class \"$name\" definition error, even number of arguments required." } } else { # class already defined.. # raise error here... puts stdout "class \"$name\" already defined." } } else { # invalid syntax... # raise error here... puts stdout "invalid class name \"$name\"." } } ############################################################################### proc object_destroy { object } { global class_objects if {[info exists class_objects($object,object)] != "0"} then { # remove all procs and vars for object and the namespace itself namespace delete $object # unset "object" storage... unset class_objects($object,object) unset class_objects($object,name) # remove global object dispatch proc rename $object "" } else { puts stdout "cannot destroy object \"$object\", not found." } } ############################################################################### proc class_destroy { name } { global class_names global class_procs global class_variables if {[class_validName $name] != "0"} then { if {[info exists class_names($name,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) } } unset class_names($name,name) } else { puts stdout "cannot destroy class \"$name\", not found." } } else { puts stdout "cannot destroy class \"$name\", invalid name." } } ############################################################################### proc object { name } { 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 {[info exists class_objects($this_object_name,object)] == "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 $class_procs($this_name) set this_proc_args $class_procs($name,$this_proc_name,args) set this_proc_body $class_procs($name,$this_proc_name,body) set this_proc_body "[class_variableDeclarations $name]\nset name $name\nset this $this_object_name\n\n$this_proc_body" # fixup self references to allow fully qualified calls... # NOTE: DEPRECATED. regsub -all -- {%this%} $this_proc_body $this_object_name this_proc_body # NOTE: this is probably not the best solution... YMMV # old way... # namespace eval $object [list proc $class_objects($object,name).$class_procs($class_objects($object,name),$proc,name) $class_procs($class_objects($object,name),$proc,args) $this_proc_body] # new way... namespace eval $this_object_name [list proc $this_proc_name $this_proc_args $this_proc_body] } } # return object "handle" set result $this_object_name } else { puts stdout "cannot create object, name generation error (this should not happen)." set result "" } } else { puts stdout "cannot create object, class \"$name\" not found." set result "" } } else { puts stdout "cannot create object, invalid class \"$name\"." set result "" } 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 {} } return "0" } ############################################################################### proc class_objects { name } { global class_objects # # return a list of active objects for one or more classes matching "name" # if {[class_validName $name] != "0"} then { 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) } } } } else { set result "" } return $result } ############################################################################### proc class_terminate {} { # # unset global variables... # uplevel "#0" { catch {unset class_names} catch {unset class_procs} catch {unset class_variables} catch {unset class_objects} } return "0" } ############################################################################### class_initialize # // end of file
Tests Source File (class_test.tcl)
############################################################################### # # Tcl "class/object" commands test script # # A simple implementation. # # Copyright (c) 2002 by Joe Mistachkin. All rights reserved. # # written by: Joe Mistachkin <[email protected]> # created on: 11/18/2002 # ############################################################################### # # 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. # ############################################################################### catch {console show} source [file join [file dirname [info script]] "class.tcl"] # make a dummy class... class emptyClass # try to make it again (this should fail) class emptyClass 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 } object_destroy thisObjectNotFound class_destroy thisClassNotFound class_destroy %%thisClassInvalidName set gz [object thisClassNotFound] set gz [object %%thisClassInvalidName] class testClass { variable x variable y variable z variable array_variable proc test0a {a} { puts stdout "TEST: [info level [info level]]"; set x $a } proc test0b {b} { puts stdout "TEST: [info level [info level]]"; set y $b } proc test1 {} { puts stdout "TEST: [info level [info level]]"; return $x.$y } proc test2 {a} { puts stdout "TEST: [info level [info level]]"; return [test0a $a] } proc test2a {a} { puts stdout "TEST: [info level [info level]]" # using %this% is DEPRECATED %this% test0a $a; return $x } proc test2b {a} { puts stdout "TEST: [info level [info level]]"; return [test3] } proc test2c {a} { puts stdout "TEST: [info level [info level]]"; $this test0a $a; return $x } proc test3 {} { puts stdout "TEST: [info level [info level]]"; return "foo" } proc test4 {a} { puts stdout "TEST: [info level [info level]]"; return $a } proc test5 {a b c} { puts stdout "TEST: [info level [info level]]"; puts stdout "a = $a"; puts stdout "b = $b"; puts stdout "c = $c" } proc test6 {a b} { puts stdout "TEST: [info level [info level]]"; error $a } proc test7 {} { puts stdout "TEST: [info level [info level]]"; return $name } proc test8 {} { puts stdout "TEST: [info level [info level]]"; return $this } proc test9 {} { puts stdout "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 {} { puts stdout "TEST: [info level [info level]]" return [array names array_variable] } } set gx [object "testClass"] set gy [$gx test0a "123"] puts stdout "$gy\n" set gy [$gx test0b "456"] puts stdout "$gy\n" set gy [$gx test1] puts stdout "$gy\n" set gy [$gx test2 "foobar"] puts stdout "$gy\n" set gy [$gx test2a "foobar"] puts stdout "$gy\n" set gy [$gx test2b "foobar"] puts stdout "$gy\n" set gy [$gx test2c "foobar"] puts stdout "$gy\n" set gy [$gx test3] puts stdout "$gy\n" set gy [$gx test4 {a b c 1 2 3}] puts stdout "$gy\n" set gy [$gx test5 {a b c 1 2 3} {a 2 2 b} 234234] puts stdout "$gy\n" catch {$gx test6 "this is an error." "huh?"} gy puts stdout "$gy\n" set gy [$gx test7] puts stdout "$gy\n" set gy [$gx test8] puts stdout "$gy\n" set gy [$gx test9] puts stdout "$gy\n" set gy [$gx test10] puts stdout "$gy\n" set gy [$gx testNotFound] puts stdout "$gy\n" puts stdout "class testClass objects: [class_objects testClass]" object_destroy $gx puts stdout "namespace exists: [namespace exists $gx]" # clear object ref variable set gx "" class_destroy testClass class_destroy emptyClass puts stdout "class names elements remaining (should be zero): [llength [array names class_names]]" puts stdout "class objects elements remaining (should be zero): [llength [array names class_objects]]" puts stdout "class procs elements remaining (should be zero): [llength [array names class_procs]]" puts stdout "class variables elements remaining (should be zero): [llength [array names class_variables]]"
Version History