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

See also [itins], [snit]

----
[Category Object Orientation]