XOTcl Is Now Simpler
Sarnold 2005-10-05 -- I am trying to emulate snit with an XOTcl class...
I am not sure it would work fine for widgets.
This software has now its own page : http://sarnold.free.fr/xoins/
Here is the source:
catch {package require XOTcl}
catch {namespace import xotcl::*}
namespace eval xoins {
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]"
}
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 typeconstructor {body} {
my proc typeconstructor {} $body
my set __meta(typeconstructor) yes
}
type proc constructor {arglist body} {
my parameter [list {self [self]}]
my proc constructor args {uplevel next $args}
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
# }
# }
my set __meta(constructor) yes
}
type proc destructor {body} {
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} {
# 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 ""}} {
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 {
if {$name=="*"} {error "delegate method * not yet implemented"}
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} {
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} {
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} {
# meta-information
my array set __meta {constructor no typeconstructor no target ""}
# 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"
}
}
# here for the world
package provide xoins 0.1A 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.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 {
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
variable content tea
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
oncget -color {
return Color=$options(-color)
}
option -content -default tea -cgetmethod getTea
variable content tea
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