XOTcl Is Not Snit
Sarnold 2005-10-05 -- I am trying to emulate snit with an XOTcl class...
What : Xoins Where : http://sarnold.free.fr/xoins/index.en.html Version : 2006-02-20 v0.5, patchlevel 1 Description : Xoins is a package emulating [snit] with the same syntax. A great speed improvement is achieved by building types as [XOTcl] classes. Switching from snit types, widgets and widgetadaptors may only require a package require xoins, and then moving snit::type to xoins::type, as for widget and widgetadaptor.
Here is the source:
package require XOTcl catch {namespace import xotcl::*} namespace eval xoins { namespace export _type widget Class create _type -superclass Class _type set __keywords {constructor delegate destructor method variable option typevariable typeconstructor proc self hull init options} _type instproc instvars {} { set vars [list]; set c [self] for {} {![string equal ::xotcl::Object $c]} {set c [$c info superclass]} { eval lappend vars [$c set __autovars] } return "\n\tmy instvar [lsort -unique $vars]\n[my typevars]" } _type instproc typevars {} { if {[llength [my set __typevars]]==0} { return "" } set l "\n\tupvar " foreach var [my set __typevars] { #puts here lappend l [self]::$var $var } return $l } _type instproc instvarsinit {} { set code "" # iterate through the instance variables # skip the first two vars : $self & $options foreach var [lrange [my set __autovars] 2 end] default [my set __defaultvals] { append code "set $var [list $default];" } #puts code=$code return "${code}array set options {};set self \[self\]" } _type instproc optinit {} { set keyvalues [list] foreach option [my set __options] default [my set __optdefaults] { lappend keyvalues $option [list $default] } set keyvalues [list $keyvalues] return "my array set options $keyvalues" } _type proc typevariable {name args} { if {[my set __meta(eov)]} { error "type variable defined after methods" } my lappend __typevars $name if {[llength $args]==1} { my set $name $args return } if {![string equal [lindex $args 0] -array]} { error "-array option expected, got '[lindex $args 0]'" } if {[llength $args]>2} { error "too many argument in typevariable statement" } my array set $name [lindex $args 1] } _type proc typeconstructor {body} { my proc typeconstructor {} [my typevars]\n$body my set __meta(typeconstructor) yes my set __meta(eov) yes } _type proc hulltype {widget} { if {[my set __meta(eov)]} { error "hulltype statement called too late" } if {[my set __meta(hull)]!="frame"} { error "hulltype statement called twice" } my set __meta(hull) $widget } proc deleteWidget {wpath} { [string range $wpath 1 end] destroy } _type proc constructor {arglist body} { my set __meta(eov) yes my parameter [list {self [self]}] my proc constructor args {uplevel next $args} if {[my set __meta(widget)]} { if {[llength $arglist]!=0} { # we need to delay the configure action after the creation of the object error "widget-specific constructor cannot take arguments" } # the name of the object is the widget path without the leading dot set wbody "set hull .\[lindex \[split \$self ::\] end\]\n" # this creates the 'hull' (megawidget container) append wbody "[my set __meta(hull)] \$hull\n" # binds the object's destruction to the one of the widget append wbody "bind \$hull <Destroy> \{xoins::deleteWidget %W\}\n" set body $wbody$body } set body [my instvars]\n[my instvarsinit]\n[my optinit]\n$body my instproc init $arglist $body # my instproc create {args} { # if {[string equal [lindex $args 0] %AUTO%]} { # next [lreplace $args 0 0 "\[autoname a\]"] # } else { # next # } # } if {[my set __meta(widget)]} { # constructs the hull special method set body { if {[llength [info procs ::[my set hull]:cmd]]} { return [my set hull] } set hull [my set hull] rename $hull ::${hull}:cmd proc ::$hull {args} [string map [list %PATH% $self] { return [eval [linsert $args 0 %PATH%]] }] return $hull } my instproc hull {} [my instvars]\n$body } my set __meta(constructor) yes } _type proc destructor {body} { my set __meta(eov) yes my proc destructor args {uplevel next $args} set body [my instvars]\n$body my instproc destroy args $body # a destructor is not required normally #my set __meta(destructor) yes } # typemethod : defined as a subcommand of the class _type proc typemethod {name arglist body} { proc [self]::$name $arglist [my typevars]\n$body } _type proc method {name arglist body} { my set __meta(eov) yes # we do not accept some reserved method names if {[lsearch [_type set __keywords] $name]>=0} { error "'$name' is a reserved word, cannot create method" } my proc $name args {uplevel next $args} my instproc $name $arglist [my instvars]\n$body } _type proc variable {name {default ""}} { if {[my set __meta(eov)]} { error "variable defined after methods" } my lappend __autovars $name my lappend __defaultvals $default } _type proc delegate {type name to target {as "not"} {revamped ""}} { # syntaxic sugar uniformization if {$to != "to"} { error "syntax error : missing 'to' keyword" } if {$as !="not"} { if {$as !="as"} { error "'as' expected" } } if {$revamped==""} {set revamped $name} switch -- $type { option { if {$name=="*"} { if {[my set __meta(target)]!=""} { error "delegate option * ... invoked twice" } my set __meta(target) $target } else { my lappend __deloptions [optnorm $name] my lappend __opttargets $target my lappend __revoptions [optnorm $revamped] } } method { my set __meta(eov) yes if {$name=="*"} { my instproc unknown {args} [string map [list %TARGET% $target] { [my set %TARGET%] {expand}$args }] } else { set body "\$$target $revamped \{expand\}\$args" my instproc $name {args} [my instvars]\n$body } } default {error "unknown type : must be 'option' or 'method'"} } } _type proc option {name args} { my lappend __options [optnorm $name] set default "" if {[llength $args]==1} { set default $args } else { foreach {key value} $args { switch -- $key { -default {set default $value} -configuremethod {my set __onconfig($name) $value} -cgetmethod {my set __oncget($name) $value} default {error "unknown option's argument : $key"} } } } my lappend __optdefaults $default } _type proc onconfigure {option value body} { my set __meta(eov) yes set option [optnorm $option] if {[lsearch [my set __options] $option]<0} { error "option not defined in onconfigure definition" } if {[my exists __onconfig($option)]} { error "onconfigure method defined twice" } my set __onconfig($option) _configuremethod$option my instproc [my set __onconfig($option)] {option value} \ [my instvars]\n[string map [list $value value] $body] } _type proc oncget {option body} { my set __meta(eov) yes set option [optnorm $option] if {[lsearch [my set __options] $option]<0} { error "option not defined in oncget definition" } if {[my exists __oncget($option)]} { error "oncget method defined twice" } my set __oncget($option) _cgetmethod$option my instproc [my set __oncget($option)] {option} [my instvars]\n$body } _type instproc init {classdef {iswidget no}} { # meta-information : eov means 'end of variables declarations' my array set __meta [list constructor no typeconstructor no target "" \ eov no widget $iswidget hull frame] # typevariable's my set __typevars "" #my set __typemethods "" # variable's my set __autovars {self options} my set __defaultvals "" # non-delegated options my set __options "" my set __optdefaults "" my array set __onconfig {} my array set __oncget {} # delegated options my set __deloptions "" my set __opttargets "" my set __revoptions "" # replace proc keyword by 'typemethod' set classdef [regsub -all -line {^([ \t]*)proc} $classdef \\1typemethod] namespace eval [self class] $classdef my postprocess my class Class } _type instproc postprocess {} { if {![my set __meta(constructor)]} { error "constructor missing in type declaration" } if {[my set __meta(typeconstructor)]} { # calls the typeconstructor my typeconstructor } set nondel [lsort -unique [my set __options]] set del [lsort -unique [my set __deloptions]] if {[llength [set total [concat $nondel $del]]]!=[llength [lsort -unique $total]]} { error "duplicate option : [findduplicate $total]" } set onconfig [list];set configurators [list] foreach {key value} [my array get __onconfig] { lappend onconfig $key lappend configurators $value } my instproc configure {args} [my instvars]\n[string map [list \ %DELOPTIONS% [my set __deloptions]\ %OPTTARGETS% [my set __opttargets]\ %REVOPTIONS% [my set __revoptions]\ %ONCONFIG% $onconfig\ %CONFIGURATORS% $configurators\ %TARGET% [my set __meta(target)]] { if {![my exists __created]} { my set __created 1 return } if {[llength $args]==0} { # called without arguments : displays the options/values list return [my array get options] } if {[llength $args]==1} { # a hint to avoid using {expand} in the constructor: # constructor {arg1 arg2 args} {... $self configure $args} # <type> <id> arg1 arg2 ?-option value ?-option value ...?? set args [lindex $args 0] } foreach {option value} $args { if {[set index [lsearch -exact {%DELOPTIONS%} $option]]>=0} { [set [lindex {%OPTTARGETS%} $index]] configure \ [lindex {%REVOPTIONS%} $index] $value continue } if {[my exists options($option)]} { if {[set index [lsearch -exact {%ONCONFIG%} $option]]<0} { my set options($option) $value } else { my [lindex {%CONFIGURATORS%} $index] $option $value } } elseif {{%TARGET%}!=""} { # when we have : delegate method * to TARGET... [my set %TARGET%] configure $option $value } } }] set oncget [list];set cgetters [list] foreach {key value} [my array get __oncget] { lappend oncget $key lappend cgetters $value } my instproc cget {args} [my instvars]\n[string map [list \ %DELOPTIONS% [my set __deloptions]\ %OPTTARGETS% [my set __opttargets]\ %REVOPTIONS% [my set __revoptions]\ %ONCGET% $oncget\ %CGETTERS% $cgetters\ %TARGET% [my set __meta(target)]] { if {[llength $args]==0} { # called without arguments : error error "cget method called with no arguments" } if {[llength $args]==1} { # a hint to avoid using {expand} in the constructor: # constructor {arg1 arg2 args} {... $self configure $args} # <type> <id> arg1 arg2 ?-option value ?-option value ...?? set args [lindex $args 0] } set result [list] foreach option $args { if {[set index [lsearch -exact {%DELOPTIONS%} $option]]>=0} { lappend result [[set [lindex {%OPTTARGETS%} $index]] cget \ [lindex {%REVOPTIONS%} $index]] continue } if {[my exists options($option)]} { if {[set index [lsearch -exact {%ONCGET%} $option]]<0} { lappend result [my set options($option)] } else { lappend result [my [lindex {%CGETTERS%} $index] $option] } } elseif {{%TARGET%} !=""} { lappend result [[my set %TARGET%] cget $option] } } return $result }] } proc optnorm {optname} { if {[string index $optname 0]!="-"} { error "bad option name: it must begin by a dash" } if {![string is lower [set s [string range $optname 1 end]]]} { error "bad option name: it must be lower-case" } return $optname } proc findduplicate {liste} { foreach elt [set l $liste] { set l [lrange $l 1 end] if {[lsearch -exact $l $elt]>=0} { return $elt } } error "no duplicate in list" } proc widget {type body} { # destroys the existing alias catch {interp alias {} $type {}} # the third argument means : 'yes, it is a widget' _type ::Widget$type "variable hull\n$body" yes interp alias {} $type {} xoins::wset ::Widget$type } proc type {type body} { # destroys the existing alias catch {interp alias {} $type {}} # the third argument means : 'yes, it is a widget' if {[catch {_type ::Xoins$type $body}]} { _type ::$type $body } interp alias {} $type {} xoins::tset ::Xoins$type return ::$type } proc wset {classname path args} { # prepend "Xoins" to the widget's path [namespace eval :: [list $classname Xoins$path]] hull $path configure $args return $path } proc tset {classname instname args} { if {[string equal destroy $instname]} { $classname destroy # destroy the alias, too catch {interp alias {} [string range $classname 7 end] {}} return } # manage autoname'd instances if {[string first %AUTO% $instname]<0} { return [namespace eval :: [linsert $args 0 $classname $instname]] } if {![string equal $instname %AUTO%]} { if {![string equal [string range $instname end-5 end] %AUTO%]} { error "%AUTO% must be the tail of the instance name" } set name [$classname autoname [string range $instname 0 end-6]] } else { set name [$classname autoname [string range $classname 7 end]] } return [namespace eval :: [linsert $args 0 $classname $name]] } } # here for the world package provide xoins 0.2
A test suite showing examples :
package require xoins package require tcltest catch {namespace import tcltest::*} test xoins-1.0.0 "No constructor error" -body { xoins::type Void {} } -returnCodes error -result ::Void test xoins-1.0.1 "Just a constructor" -body { xoins::type Void { constructor {} {} } } -cleanup {Void destroy} -result ::Void test xoins-1.0.2 "Just a constructor" -body { xoins::type Void { constructor {} {} } Void a } -cleanup {a destroy;Void destroy} -result ::a test xoins-1.1.0 "Variables" -body { xoins::type Void { variable a variable b 3 constructor {} {} } Void a list [a set a] [a set b] } -cleanup {a destroy;Void destroy} -result "{} 3" test xoins-1.1.1 "Methods" -body { xoins::type Void { variable a variable b 3 constructor {} {set a 0} method add {{n 1}} {incr a $n;return $a} } Void a a add } -cleanup {a destroy;Void destroy} -result "1" test xoins-1.1.2 "Delegated methods" -body { xoins::type Counter { variable c 0 constructor {{initial 0}} {set c $initial} method add {{n 1}} {incr c $n} } xoins::type Interface { variable c constructor {} {set c [Counter c]} destructor {$c destroy} delegate method add to c } Interface a a add } -cleanup { a destroy Interface destroy Counter destroy } -result 1 test xoins-1.1.3 "Typevariables" -body { xoins::type Void { typevariable a -array {3 road 4 path} typevariable b 3 constructor {} {} } Void a list [lsort [Void array get a]] [Void set b] } -cleanup {a destroy;Void destroy} -result "[list [lsort {3 road 4 path}]] 3" test xoins-1.1.4 "Typevariables & typeconstructor" -body { xoins::type Void { typevariable a -array {3 road 4 path} typevariable b 3 typeconstructor {set a(3) railroad;set b 4} constructor {} {} } #Void a list [lsort [Void array get a]] [Void set b] } -cleanup {Void destroy} -result "[list [lsort {3 railroad 4 path}]] 4" test xoins-1.1.4bis "Declare typeconstructor before typevariables" -body { xoins::type Void { # a and b are not yet defined -> this raises an error typeconstructor {set a(3) railroad;set b 4} typevariable a -array {3 road 4 path} typevariable b 3 constructor {} {} } } -returnCodes error -result ::Void test xoins-1.1.5 "Typevariables used in constructor" -body { xoins::type Void { # a and b are not yet defined -> this raises an error typevariable nbInstances 0 constructor {} {incr nbInstances} destructor {incr nbInstances -1} method getInstNumber {} {return $nbInstances} } Void a Void b Void c a getInstNumber } -cleanup { a destroy b destroy c destroy Void destroy } -result 3 test xoins-1.1.6 "Delegating method *" -body { xoins::type Counter { variable c 0 constructor {{initial 0}} {set c $initial} method add {{n 1}} {incr c $n} method square {} {set c [expr {$c*$c}]} } xoins::type Interface { variable c constructor {} {set c [Counter c]} destructor {$c destroy} delegate method * to c } Interface a a add set result [a add] lappend result [a square] } -cleanup { a destroy Interface destroy Counter destroy } -result {2 4} test xoins-1.1.7 "Type procedures 1" -body { xoins::type Void { constructor {} {} proc addone {{n 1}} {incr n} } set a [Void addone 1] } -cleanup { Void destroy } -result {2} test xoins-1.1.8 "Type methods" -body { xoins::type InstCounter { typevariable counter 0 constructor {} {incr counter} destructor {incr counter -1} typemethod counter {} {return $counter} } InstCounter a InstCounter b InstCounter c set nb [InstCounter counter] c destroy b destroy a destroy lappend nb [InstCounter counter] return $nb } -cleanup { InstCounter destroy } -result {3 0} test xoins-1.2.0 "Options" -body { xoins::type Counter { option -counter 0 constructor {} {} method add {{n 1}} { set c [$self cget -counter] incr c $n $self configure -counter $c return $c } } xoins::type Interface { variable c constructor {} {set c [Counter c]} destructor {$c destroy} delegate method add to c } Interface a a add } -cleanup { a destroy Interface destroy Counter destroy } -result 1 test xoins-1.2.1 "Delegated options" -body { xoins::type Cupoftea { option -size 10 option -color white option -content tea constructor {args} {$self configure $args} } xoins::type Interface { variable c constructor {} {set c [Cupoftea c]} destructor {$c destroy} delegate option -size to c delegate option * to c } Interface a a configure -size 12 set result [a cget -size] a configure -color blue lappend result [a cget -color] } -cleanup { a destroy Interface destroy Cupoftea destroy } -result {12 blue} test xoins-1.2.2 "Onconfigure methods" -body { xoins::type Cupoftea { variable content tea option -size 10 option -color white variable color white onconfigure -color {val} { set color $val set options(-color) $val } option -content -default tea -configuremethod setTea method setTea {option value} { if {![string equal $option -content]} { error "option has to be -content" } set content $value set options(-content) $value } constructor {args} {$self configure $args} } xoins::type Interface { variable c constructor {} {set c [Cupoftea c]} destructor {$c destroy} delegate option -size to c delegate option * to c } Interface a a configure -content coffee -color red return [list [c set content] [c set color]] } -cleanup { a destroy Interface destroy Cupoftea destroy } -result {coffee red} test xoins-1.2.3 "Oncget methods" -body { xoins::type Cupoftea { option -size 10 option -color white variable color white variable content tea oncget -color { return Color=$options(-color) } option -content -default tea -cgetmethod getTea method getTea {option} { if {![string equal $option -content]} { error "option has to be -content" } return Content=$options(-content) } constructor {args} {$self configure $args} } xoins::type Interface { variable c constructor {} {set c [Cupoftea c]} destructor {$c destroy} delegate option -size to c delegate option * to c } Interface a a configure -content coffee -color red return [a cget -color -content] } -cleanup { a destroy Interface destroy Cupoftea destroy } -result {Color=red Content=coffee} test xoins-1.3.0 "Autonaming instances" -body { xoins::type Counter { variable a 0 constructor {{n 0}} {set a $n} method add {{n 1}} { incr a $n return $a } } set a [Counter a%AUTO%] set b [Counter %AUTO% 1] return [list [$a add] [$b add]] } -cleanup { $a destroy $b destroy Counter destroy } -result {1 2} test xoins-1.3.1 "Autonaming components" -body { xoins::type Counter { variable a 0 constructor {{n 0}} {set a $n} method add {{n 1}} { incr a $n return $a } } xoins::type Apple { option -color red variable counter constructor {} { set counter [Counter %AUTO%] } destructor { $counter destroy } delegate method add to counter } Apple a Apple b a add b add } -cleanup { a destroy b destroy Apple destroy Counter destroy } -result {1} test xoins-1.3.2 "Autonaming and passing arguments to the constructor" -body { xoins::type Counter { variable a 0 constructor {{n 0}} {set a $n} method add {{n 1}} { incr a $n return $a } } xoins::type Apple { option -color red variable counter constructor {n} { set counter [Counter %AUTO% $n] } destructor { $counter destroy } delegate method add to counter } Apple a 0 Apple b 1 list [a add] [b add] } -cleanup { a destroy b destroy Apple destroy Counter destroy } -result {1 2} cleanupTests