XOTcl Is Not Snit
Sarnold 2005-10-05 -- I am trying to emulate snit with an XOTcl class...
This software has now its own page : http://sarnold.free.fr/xoins/
2005-10-08 -- It now has the ability to create megawidgets, through a xoins::widget command.
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.2A 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