'''Incr Tcl Is Now Simpler'''

[Sarnold] 2005/07/11 - It is an object-oriented package built on the top of [incr Tcl], but based upon delegation like [snit] does.

Here is the source :

 namespace eval itins {
    # export public commands
    namespace export type delete
    # global variables representing the current type's structure
    variable className
    variable methods
    variable variables
    variable procs
    variable special
    variable nonDelegatedOptions
    variable unknowns
    variable delegatedOptions
    variable oncfg
    variable onget
    
    proc type {name body {filename ""}} {
        # clean up
        catch {itcl::delete class $name}
        variable className
        set className $name
        # initializing arrays
        foreach varName {methods delegatedOptions procs unknowns oncfg onget special} {
            variable $varName
            array unset $varName
            array set $varName {}
        }
        # and now initializing simple values
        foreach varName {
            nonDelegatedOptions
            variables options typevars typearys} {
            variable $varName
            set $varName ""
        }
        # evaluate the body in current context
        # to perform preprocessing
        namespace eval ::itins::eval $body
        set body "\{\n[classBody]\n\}"
        # store the class into a file,
        if {$filename!=""} {
            set fd [open $filename w]
            puts $fd itcl::class $className $body"
            close $fd
            return
        }
        # or use it just now (beware of :: because, if it wasn't here,
        # we would get a class inside the itins namespace !)
        eval itcl::class ::$className $body
        return
    }
    
    # process variables-related code generation
    proc variables {} {
        variable variables
        variable typevars
        variable typearys
        set result "# variables (instance and common)\n"
        set allvars [concat [keys $variables] [keys $typevars] [keys $typearys]]
        # to check that there are no multiple definition
        findDupKeys $allvars variable
        foreach {name default} $variables {
            append result "private variable $name $default\n"
        }
        foreach {name default} $typevars {
            append result "private common $name $default\n"
        }
        foreach {name default} $typearys {
            append result "private common $name\narray set $name $default"
        }
        return $result
    }
    
    # check whether there are duplicated keys
    proc findDupKeys {keys type} {
        foreach my $keys {
            if {[llength [lsearch -all $keys]]>1} {
                error "$type $my defined twice"
            }
        }
    }
        
    
    # returns keys in a pair-list : {key1 value1 key2 value2 ...}
    # the pair-list can be any tuple, provided $by is set to the
    # number of elements in the tuple
    proc keys {pairs {by 2}} {
        set result {}
        for {set i 0} {$i<[llength $pairs]} {incr i $by} {
            lappend result [lindex $pairs $i]
        }
        return $result
    }
    
    # generate code related to construction and destruction of object
    proc specials {} {
        variable special
        if {![info exists special(constructor)]} {
            error "no instance constructor"
        }
        if {![info exists special(destructor)]} {
            error "no instance destructor"
        }
        set cons $special(constructor)
        set result [list constructor [lindex $cons 0] [lindex $cons 1]]\n
        append result "destructor [list $special(destructor)]\n"
        return $result
    }
    
    
    # build procs bodies
    proc procs {} {
        variable procs
        set result "# proc definitions\n"
        foreach name [array names procs] {
            append result [list proc $name [lindex $procs($name) 0] \
                    [lindex $procs($name) 1]]\n
        }
        return $result
    }
    
    # build the methods bodies
    proc methods {} {
        variable methods
        set result "# methods definitions\n"
        foreach name [array names methods] {
            foreach {arglist body} $methods($name) {break}
            append result [list public method $name $arglist $body]\n
        }
        return $result
    }
    
    proc checkAllOptions {} {
        variable delegatedOptions
        variable nonDelegatedOptions
        set allOpts [keys $nonDelegatedOptions 3]
        foreach target [array names delegatedOptions] {
            lappend allOpts [keys $delegatedOptions($target)]
        }
        findDupKeys $allOpts "option"
    }
    
    # build the onconfigure and oncget special methods
    proc options {} {
        checkAllOptions
        variable nonDelegatedOptions
        variable delegatedOptions
        set cfgbody "# configure body\npublic method configure args \{\n"
        append cfgbody "foreach {option value} \$args \{\n"
        set cgetbody "# cget body\npublic method cget args \{\n"
        append cgetbody "foreach option \$args \{\n"
        foreach target [array names delegatedOptions] {
            set optlist {}
            set newformlist {}
            foreach {option newform} $delegatedOptions($target) {
                lappend optlist $option
                lappend newformlist $newform
            }
            # if {[set index [lsearch <optlist> $option]]>=0} {<target> configure [lindex <newformlist> $index] $value
            # return}
            #
            set stmt "if \{\[set index \[lsearch -exact [list $optlist] \$option\]\]>=0\} \{\n"
            append cfgbody $stmt
            append cfgbody "\$$target configure \[lindex [list $newformlist] \$index\] \$value\n"
            append cfgbody "return\n\}\n"
            append cgetbody $stmt
            append cgetbody "return \[\$$target cget \[lindex [list $newformlist] \$index\]\]\n"
            append cgetbody "\}\n"
            
        }
        set stmt "switch -exact -- \$option \{\n"
        append cfgbody $stmt
        append cgetbody $stmt
        set optdef "# options\n"
        foreach {option default readonly} $nonDelegatedOptions {
            set name [string range $option 1 end]
            append optdef "public variable $name $default\n"
            append cfgbody "$option \{[cfgbody $option $readonly]\}\n"
            append cgetbody "$option \{[cgetbody $option]\}\n"
            
        }
        variable unknowns
        if {[info exists unknowns(options)]} {
            append cfgbody "default \{\$$unknows(options) configure \$option \$value\}\n"
            append cgetbody "default \{return \[\$$unknows(options) cget \$option\]\}\n"
        } else  {
            set dontKnow "default \{error \"unknown option '\$option'\"\}\n"
            append cfgbody $dontKnow
            append cgetbody $dontKnow
        }
        set closing "\}\n\}\n\}\n"
        append cfgbody $closing
        append cgetbody $closing
        return "${optdef}\n${cfgbody}\n${cgetbody}\n"
    }
    
    proc cfgbody {option readonly} {
        variable oncfg
        set body ""
        if {[info exists oncfg($option)]} {
            if {$readonly} {
                error "can't configure readonly option '$option'"
            }
            set cfg $oncfg($option)
            # replace $value by the local varname
            append body [string map [list value [lindex $cfg 0]] [lindex $cfg 1]]\n
        }
        if {$readonly} {
            append body "error \"this option is read-only\""
        }
        # the variable hanging to an option
        set name [string range $option 1 end]
        append body "set $name \$value"
        return $body
    }
    
    # build the 'cget' method body
    proc cgetbody {option} {
        variable onget
        set body ""
        if {[info exists onget($option)]} {
            append body "$onget($option)\n"
        }
        # the variable hanging to an option
        set name [string range $option 1 end]
        append body "return \$$name"
        return $body
    }
    
    # build the class-body (for [incr Tcl])
    proc classBody {} {
        set result [variables]
        # constructor & destructor
        append result [specials]
        append result [procs]
        append result [methods]
        append result [options]
        return $result
    }
    
    proc delete {args} {
        uplevel itcl::delete object $args
    }
    
    
    proc delegateMethod {args} {
        set args [lindex $args 0]
        set method [lindex $args 0]
        set args [lrange $args 1 end]
        if {$method eq "*"} {
            # not yet implemented : delegate method * to <target>
            foreach {to target} $args {
                variable unknowns
                error "delegate unknown methods is not yet implemented"
            }
        } else  {
            # but yet implemented : delegate method <name> to <target>
            foreach {to target} $args {break}
            set newform $method
            catch {foreach {as newform} \
                        [set args [lrange $args 2 end]] {break}}
            itins::eval::method $method args "eval \$$target $newform \$args"
        }
    }
    
    proc delegateOption {args} {
        set args [lindex $args 0]
        set option [lindex $args 0]
        if {[string equal $option *]} {
            variable unknowns
            foreach {to target} [set args [lrange $args 1 end]] {break}
            testSet unknowns options $target "target for unknown options already defined"
            return
        }
        validateOption $option
        foreach {to target} [set args [lrange $args 1 end]] {break}
        set newform $option
        catch {foreach {as newform} \
                    [set args [lrange $args 2 end]] {break}}
        variable delegatedOptions
        validateOption $newform
        AryLappend delegatedOptions $target [list $option $newform]
    }
    
    proc validateOption {option} {
        if {[string index $option 0] != "-"} {
            error "options should begin by a dash"
        }
        if {![string is alnum [string range $option 1 end]]} {
            error "options should be alpha-numeric"
        }
    }
    
    
    
    # utility procs
    proc AryLappend {arrayName key value} {
        upvar $arrayName arrayVar
        if {![info exists arrayVar($key)]} {
            set arrayVar($key) $value
            return
        }
        lappend arrayVar($key) $value
        return
    }
    
    proc testSet {arrayName key value errMsg} {
        upvar $arrayName arrayVar
        if {[info exists arrayVar($key)]} {
            error $errMsg
        }
        set arrayVar($key) $value
    }
 }

 # commands that can be invoked in the itins::type body
 namespace eval itins::eval {
    ::proc constructor {arglist body} {
        itins::testSet itins::special constructor [list $arglist $body] "constructor redefined"
    }
    
    ::proc destructor {body} {
        itins::testSet itins::special destructor $body "destructor redefined"
    }
    
    
    ::proc method {name args body} {
        itins::testSet itins::methods $name [list $args $body] "method redefined"
    }
    
    ::proc proc {name args body} {
        itins::testSet itins::procs $name [list $args $body] "proc redefined"
    }
    
    ::proc delegate {args} {
        switch -- [lindex $args 0] {
            method {itins::delegateMethod [lrange $args 1 end]}
            option {itins::delegateOption [lrange $args 1 end]}
            default {error "can delegate only methods or options"}
        }
    }
    
    ::proc typevariable {name args} {
        if {[string equal [lindex $args 0] -array]} {
            lappend itins::typearys $name [lindex $args 1]
            return
        }
        lappend itins::typevars $name [lindex $args 0]
    }
    ::proc variable {name {default ""}} {
        lappend itins::variables $name $default
    }
    
    ::proc option {name {default ""} {readonly no}} {
        itins::validateOption $name
        set readonly [string equal $readonly -readonly]
        lappend itins::nonDelegatedOptions $name $default $readonly
    }
    
    ::proc onconfigure {option arg body} {
        itins::validateOption $option
        itins::testSet itins::oncfg $option [list $arg $body] "onconfigure already defined for this option"
    }
    
    ::proc oncget {option body} {
        itins::validateOption $option
        itins::testSet itins::onget $option $body "oncget already defined for this option"
    }
 }
 package provide itins 0.1   
----
'''An example :'''

 package require Itcl

 package require itins

 itins::type Tool {
    option -setting "select"
    constructor {} {}
    destructor {}
    onconfigure -setting {value} {
        #puts "Tool setting!"
    }
    oncget -setting {
        #puts "Tool get settings!"
    }
    method tell {message} {
        return "Tool is telling you : '$message'"
    }
    method sing {who what} {
        return "$who sings : '$what'"
    }
 }

 itins::type Person {
    variable name
    variable tool
    option -decorate no
    delegate option -setting to tool
    constructor {myname} {
        set name $myname
        set tool [Tool #auto]
    }
    destructor {itins::delete $tool}
    delegate method tell to tool
    delegate method singing to tool as {sing "Queen"}
    method print {} {
        set msg "My name is $name, and I am "
        if {!$decorate} {
            append msg "not "
        }
        append msg "decorated.\nMy tools settings are [cget -setting]."
        return $msg
    }
    method try {look} {
        return "I am trying to look at $look."
    }
    method whenBusy {{overclock no}} {
        set msg [print]
        append msg "\nWhen I am busy, I do "
        if {!$overclock} {
            append msg "not "
        }
        return "${msg}overclock my CPU."
    }
    #test procs!
    proc Hello {what} {
        return "Hello $what!"
    }
 }

 set t [Person #auto "Steve McQueen"]
 puts [$t tell "This is the truth : I am a liar"]
 puts [$t singing "We will rock you!"]
 itins::delete $t
 
'''July 11, 2005''' [SRIV] There seems to be a missing method "tell" in the demo. [Sarnold]fixed :).
----
[Category Object Orientation] [Category Package]