Rob: Protected "Programming:Tcl Basique (unauthorized copy)": don't want anyone to muck with this copy; they should work with the original [edit=sysop:move=sysop]

2008-12-21T09:29:37Z

Protected "Programming:Tcl Basique (unauthorized copy)": don't want anyone to muck with this copy; they should work with the original [edit=sysop:move=sysop]

← Older revision	Revision as of 02:29, 21 December 2008
(No difference)

Rob: unauthorized copy (with some edits to make it work on MediaWiki)

2008-12-21T09:28:51Z

unauthorized copy (with some edits to make it work on MediaWiki)

New page

THIS IS AN UNAUTHORIZED COPY OF THE PAGE Basique. THE ORIGINAL PAGE IS HERE: [http://wiki.tcl.tk/15750 Basique]

(I'm making a copy just in case [http://wiki.tcl.tk http://wiki.tcl.tk] goes away, but with a great domain like that, I imagine it will be stable for a while.)

----
[http://wiki.tcl.tk/9126 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>

Programming:Tcl Basique (unauthorized copy) - Revision history

Rob: Protected "Programming:Tcl Basique (unauthorized copy)": don't want anyone to muck with this copy; they should work with the original [edit=sysop:move=sysop]

Rob: unauthorized copy (with some edits to make it work on MediaWiki)