Programming:Tcl Basique (unauthorized copy)
THIS IS AN UNAUTHORIZED COPY OF THE PAGE Basique. THE ORIGINAL PAGE IS HERE: Basique
(I'm making a copy just in case http://wiki.tcl.tk goes away, but with a great domain like that, I imagine it will be stable for a while.)
Sarnold is the creator of this software.
basique.tcl <source lang="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
</source>
