Sarnold thinks that classes should look, as much as possible, like namespaces because it is the current encapsulation model. It may be extreme, but some developers may want to quickly convert a namespace into a Class or Megawidget, while the opposite would not be as simple. I would like to see:
namespace class foo {
common counter
variable names
proc __init__ {args} {
common counter
incr counter
variable names
array set names $args
}
# it has to look like a normal Tcl proc, so it has an arglist
proc __destroy__ {} {
common counter
incr counter -1
}
proc display {} {
variable names
puts "My name is $names(first) $names(last)"
}
proc count {} {
common counter
return $counter
}
}
foo new name first Richard last Heinz
name destroy
set name [foo %AUTO% first Richard last Heinz]
$name display
set name::names(first) George
$name display
# generates an error, because it is an instance method
#foo display
$name destroyWhere common would behave like variable, with a static qualifier. I submit that a sequence of variable bar may be replaced by instance command that wraps all variable calls related to (instance) variables.
basique.tcl
namespace eval ::basique {
namespace export class
variable classes
array set classes {}
proc class {name code} {
if {[string range $name 0 1] ne {::}} {
set name ::$name
}
variable classes
if {[info exists classes($name)]} {
cdelete $name
}
set common_prelude [string map [list %NAME% $name] {
# does nothing
proc variable {var args} {
lappend ::basique::classes(%NAME%,instvars) $var
}
# provide common variable statement
proc common {var args} {
if {[llength $args] > 1} {
error {common varname ?default?}
}
if {[llength $args] == 0} {
uplevel 1 ::variable $var
return
}
uplevel 1 ::variable $var [lindex $args 0]
return
}
proc alias {name args} {
if {[llength $name] != 1} {
error {cannot create such a composite alias}
}
proc $name {args} [string map [list ARGS $args] {
eval [linsert $args 0 ARGS]
}]
}
proc component {var args} {
foreach {opt val} $args {
switch -- $opt {
-common {set common $val}
-initscript {::basique::initscript %NAME% $val $var $common}
-destroyscript {::basique::destroyscript %NAME% $val $var $common}
default {
error {option should be one of : -common -initscript -destroyscript}
}
}
}
if {![info exists common] || !$common} {
return
}
proc $var {subcmd args} [string map [list VAR $var] {
common VAR
uplevel 1 [linsert $args 0 $VAR $subcmd]
}]
}
}]
namespace eval $name $common_prelude\n$code
if {[info exists classes($name,compinit)]} {
namespace eval $name $classes($name,compinit)
}
catch {${name}::__classinit__}
set classes($name) $code
CreateClass $name
}
proc initscript {class script var common} {
variable classes
if {$common} {
append classes($class,compinit) "common $var\n $script\n"
} else {
append classes($class,instcompinit) "variable $var\n $script\n"
}
}
proc destroyscript {class script var common} {
variable classes
if {$common} {
append classes($class,compdestroy) "common $var\n $script\n"
} else {
append classes($class,instcompdestroy) "variable $var\n $script\n"
}
}
proc cdelete {name} {
variable classes
unset classes($name)
catch {${name}::__classdestroy__}
catch {namespace eval $name $classes($name,compdestroy)}
foreach sub {instvars compinit instcompinit compdestroy instcompdestroy} {
catch {unset classes($name,$sub)}
}
catch {namespace delete $name}
catch {rename $name {}}
}
# crée la commande qui instanciera les objets
proc CreateClass {name} {
variable classes
# the 'real' constructor (__init__ is the one at user level)
# le constructeur réel (le constructeur public est __init__)
proc $name {args} [string map [list %NAME% $name] {
if {![llength $args]} {
set args {%AUTO%}
}
if {[lindex $args 0] eq "%AUTO%"} {
set args [linsert $args 0 new]
}
switch -- [lindex $args 0] {
new {
set instance [lindex $args 1]
if {$instance eq "%AUTO%"} {
set instance [::basique::autoname %NAME%]
}
set args [lrange $args 2 end]
}
default {
return [uplevel 1 namespace eval %NAME% $args]
}
}
if {[string range $instance 0 1] ne {::}} {
set instance ::$instance
}
# creates the prelude
set instance_prelude [string map [list %OBJ% $instance] {
proc common {var args} {
if {[llength $args]>1} {
error {common var ?default?}
}
if {[llength $args]==0} {
uplevel 1 [list upvar %NAME%::$var $var]
}
}
proc body {name arglist body} {
proc %OBJ%::$name $arglist $body
}
proc . {varname} {
return %OBJ%::$varname
}
proc self {} {
return %OBJ%
}
proc -> {varname} {
variable $varname
set $varname
}
proc component {var args} {
foreach {opt val} $args {
switch -- $opt {
-common {set common $val}
-initscript - -destroyscript {}
default {
error {option should be one of : -common -initscript -destroyscript}
}
}
}
if {![info exists common] || !$common} {
set type variable
uplevel 1 variable $var
} else {
set type common
}
proc $var {subcmd args} [string map [list TYPE $type VAR $var] {
TYPE VAR
uplevel 1 [linsert $args 0 $VAR $subcmd]
}]
}
proc alias {name args} {
if {[llength $name] != 1} {
error {cannot create such a composite alias}
}
proc $name {args} [string map [list ARGS $args] {
uplevel 1 [linsert $args 0 ARGS]
}]
}
}]
# insert 'instance' where you want quickly to get instance variables
# (instead, you would have to type lots of 'variable' statements)
append instance_prelude "proc instance \{\} \{\nuplevel 1 \{\n"
if {[info exists ::basique::classes(%NAME%,instvars)]} {
foreach var $::basique::classes(%NAME%,instvars) {
append instance_prelude "variable $var\n"
}
}
append instance_prelude "\}\n\}\n"
# %NAME% is preprocessed into ::myclass
# then ::myclass body's namespace is mapped into the instance namespace
set body [string map [list [string trim %NAME% :]:: \
[string trim $instance :]::] $::basique::classes(%NAME%)]
namespace eval $instance $instance_prelude
namespace eval $instance $body
# builds the instance
#puts before
if {[info exists ::basique::classes(%NAME%,instcompinit)]} {
# initscript at instance level
namespace eval %NAME% $::basique::classes(%NAME%,instcompinit)
}
uplevel 1 [linsert $args 0 ${instance}::__init__]
#puts after
proc $instance {command args} [string map [list %OBJ% $instance] {
if {$command eq {destroy}} {
%OBJ%::__destroy__
if {[info exists ::basique::classes(%NAME%,instcompdestroy)]} {
# destroyscript at instance level
namespace eval %NAME% $::basique::classes(%NAME%,instcompdestroy)
}
catch {namespace delete %OBJ%}
catch {rename %OBJ% {}}
return
}
switch -- $command {
__init__ - __destroy__ - __classinit__ - __classdestroy__ - common - instance {
error {protected command}
}
default {
return [uplevel 1 [linsert $args 0 %OBJ%::$command]]
}
}
}]
return $instance
}]
}
proc lfilter {var list condition} {
upvar $var x
set out {}
foreach x $list {
if {[uplevel 1 expr $condition]} {
lappend out $x
}
}
return $out
}
proc autoname {name} {
variable classes
if {![info exists classes($name)]} {
error "class $name not found"
}
if {![info exists classes($name,counter)]} {
set classes($name,counter) 0
}
while {[llength [info procs ${name}__$classes($name,counter)]]} {
incr classes($name,counter)
}
return ${name}__$classes($name,counter)
}
}
package provide basique 1.0Example
basique::class foo {
variable name
proc __init__ {vname} {
instance
set name $vname
}
proc __destroy__ {} {
instance
puts "Goodbye $name !"
}
}
foo new a Arnold
set [a . name] Meyer
puts [a -> name]
a destroyNow let's build a singleton handler :
basique::class Foo {
common instance
proc __classdestroy__ {} {
common instance
$instance destroy
}
proc __init__ {} {
if {[uplevel namespace current] ne {::Foo}} {
error {cannot instantiate singleton class}
}
}
proc __destroy__ {} {
}
proc getInstance {} {
common instance
if {![info exists instance]} {
set instance [::Foo]
}
return $instance
}
}
set inst {}
foreach i {1 2 3} {
lappend inst [Foo getInstance]
}
puts "singletons : $inst"ANON: 2006-07-26:
Nice Work!
I wonder how to distinguish those namespaces as classes or instances from any other namespace.
Sarnold 2006-07-29: You really hit the point! Since those classes and objects are instances of namespaces, there is, in theory, no way to distinguish them from ordinary namespaces.
But I can tell you that, to make them more object-like, for every classe and object, a command with the same name as the namespace is created. Indeed we can do :
MyClass cook veryhot
as well as :
MyClass::cook veryhot
And in fact, you are invited to use the "object-like" method for creation and destruction of objects.
So, back to our subject, to test if it is not an ordinary namespace,
proc isobject {name} {llength [info procs MyClass]}
if {[isobject MyClass]} {...}
MyClass a
if {[isobject $a]} {...}Sarnold 2008-07-14: Updated for Fiction!.