[Sarnold] thinks that classes should look, as much as possible, like [namespace%|%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 destroy
======

Where ''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.0
======

----

'''Example'''

======
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 destroy
======

Now 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!].


** Page Authors **


   [PYK]:   Cleaned up layout and reworded some things.


<<categories>> Object Orientation