''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:

 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.1

----

''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.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
 
----

See also [itins], [snit]

----
[Category Object Orientation]