XOTcl Is Now Simpler
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
}
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 {using "not"} {revamped ""}} {
# syntaxic sugar uniformization
if {$to != "to"} {
error "syntax error : missing 'to' keyword"
}
if {$using !="not"} {
if {$using !="using"} {
error "'using' 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 ""
# 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 ""
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]"
}
my instproc configure {args} [my instvars]\n[string map [list \
%DELOPTIONS% [my set __deloptions]\
%OPTTARGETS% [my set __opttargets]\
%REVOPTIONS% [my set __revoptions]\
%ONCONFIG% [my array get __onconfig]\
%TARGET% [my set __meta(target)]] {
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 {%DELOPTIONS%} $option]]>=0} {
[set [lindex {%OPTTARGETS%} $index]] configure \
[lindex {%REVOPTIONS%} $index] $value
continue
}
if {[my exists options($option)]} {
array set onconfig {%ONCONFIG%}
#if {[my exists __onconfig($option)]} {
# eval [my set __onconfig($option)]
#}
if {[info exists onconfig($option)]} {
my $onconfig($option) $option $value
} else {
my set options($option) $value
}
} elseif {{%TARGET%}!=""} {
# when we have : delegate method * to TARGET...
[my set %TARGET%] configure $option $value
}
}
}]
my instproc cget {args} [my instvars]\n[string map [list \
%DELOPTIONS% [my set __deloptions]\
%OPTTARGETS% [my set __opttargets]\
%REVOPTIONS% [my set __revoptions]\
%ONCGET% [my array get __oncget]\
%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 {%DELOPTIONS%} $option]]>=0} {
lappend result [[set [lindex {%OPTTARGETS%} $index]] cget \
[lindex {%REVOPTIONS%} $index]]
continue
}
if {[my exists options($option)]} {
array set oncget {%ONCGET%}
if {[info exists oncget($option)]} {
lappend result [my $oncget($option) $option]
} else {
lappend result [my set options($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 wset {classname path args} {
[namespace eval :: [list $classname [string range $path 1 end]]] hull
$path configure $args
return $path
}
}
# 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 {} {}
}
} -cleanup {Void destroy} -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.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}
cleanupTests