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

2005/07/18 - There is an URL to get the last version : http://sarnold.free.fr/itins/index.en.html

2005/07/17 - There is now a itins::widget command. Please note (regarding widgets) : 
   * never call hull method
   * use "hull frame" or "hull toplevel" into your widget definition (with no arguments, "hull" means "hull frame")
   * always prepend widget creation with itins::wset (see the widget example)

Here is the source :

        package require Itcl
    
    namespace eval itins {
        # export public commands
        namespace export type delete widget wset
        # global variables representing the current type's structure
        variable methods
        variable variables
        variable procs
        variable special
        variable nonDelegatedOptions
        variable unknowns
        variable delegatedOptions
        variable oncfg
        variable onget
        variable isawidget
        variable widgetHandle
        variable className
        
        
        proc type {name body {filename ""}} {
            _type $name $body $filename ""
        }
        
        proc _type {name body filename widget} {
            variable className
            cleanUp $name $widget
            # evaluate the body in current context
            # to perform preprocessing
            namespace eval ::itins::eval $body
            set body "\n[classBody]"
            # store the class into a file,
            if {$filename!=""} {
                set fd [open $filename w]
                puts $fd [list itcl::class $className $body]
                close $fd
                return
            }
            # or use it just now (beware of uplevel because, if it wasn't here,
            # we would get a class inside the itins namespace !)
            itcl::class ::$className $body
            return $className
        }
        
        proc widget {name body {filename ""}} {
            package require Tk
            _type $name $body $filename widget
        }
        
        proc wset {class path args} {
            set evaluate "$class [string range $path 1 end]"
            foreach a $args {
                set evaluate [concat $evaluate [::itins::lone $a]]
            }
            [eval $evaluate] hull
            return $path
        }
        
        proc deleteWidget {path} {
            catch {itins::delete [string range $path 1 end]}
        }
        
        proc cleanUp {cName {widget ""}} {
            # clean up
            variable className
            set className $cName
            catch {itcl::delete class $className}
            # initializing arrays
            foreach varName {methods delegatedOptions procs unknowns
                oncfg onget special widgetHandle} {
                variable $varName
                array unset $varName
                array set $varName {}
            }
            # and now initializing simple values
            foreach varName {
                nonDelegatedOptions
                variables options typevars typearys} {
                variable $varName
                set $varName ""
            }
            variable isawidget
            set isawidget [expr {$widget eq "widget"}]
            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
        }
        
        # 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 "constructor [lone [lindex $cons 0]] [widgetcons [lindex $cons 1]]\n"
            append result "destructor [widgetdestr $special(destructor)]\n"
            
            return $result
        }
        
        # the widget constructor
        proc widgetcons {mainConstructor} {
            variable isawidget
            if {!$isawidget} {return [list $mainConstructor]}
            variable widgetHandle
            set result "set hull .\[lindex \[split \$this ::\] end\]\n"
            append result "[getonce widgetHandle type frame] \$hull\n"
            append result "${mainConstructor}\n"
            append result "bind \$hull <Destroy> \{itins::deleteWidget %W\}\n"
            return [list $result]
        }
        
        # the widget destructor
        proc widgetdestr {mainDestructor} {
            variable isawidget
            if {!$isawidget} {return [list $mainDestructor]}
            set result "${mainDestructor}\n"
            append result "catch {destroy \$hull}"
            return [list $result]
        }
        
        
        # build procs bodies
        proc procs {} {
            variable procs
            set result "# proc definitions\n"
            foreach name [array names procs] {
                append result "proc $name [lone [lindex $procs($name) 0]]"
                append result " \{[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 "public method $name [lone $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 [lone args] \{\n"
            append cfgbody "if \{\[llength \$args\]==1\} \{\n"
            append cfgbody "set args \[lindex \$args 0\]\n\}\n"
            
            append cfgbody "foreach {option value} \$args \{\n"
            set cgetbody "# cget body\npublic method cget [lone args] \{\n"
            append cgetbody "set result {}\nforeach option \$args \{\n"
            # build the delegation for all delegated options
            delegatedOptionBody cfgbody cgetbody
            set optdef "# options\n"
            nonDelegatedOptionBody cfgbody cgetbody optdef
            defaultOption cfgbody cgetbody
            set closing "\}\n\}\n"
            append cgetbody "${closing}return \$result\}\n"
            append cfgbody "${closing}\}\n"
            return "${optdef}\n${cfgbody}\n${cgetbody}\n"
        }
        
        proc nonDelegatedOptionBody {cfgbodyVar cgetbodyVar optdefVar} {
            upvar $cfgbodyVar cfgbody
            upvar $cgetbodyVar cgetbody
            upvar $optdefVar optdef
            set stmt "switch -exact -- \$option \{\n"
            append cfgbody $stmt
            append cgetbody $stmt
            variable nonDelegatedOptions
            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"
            }
            return
        }
        
        proc delegatedOptionBody {cfgbodyVar cgetbodyVar} {
            upvar $cfgbodyVar cfgbody
            upvar $cgetbodyVar cgetbody
            variable delegatedOptions
            foreach target [array names delegatedOptions] {
                foreach {optlist newformlist} [pairs $delegatedOptions($target)] {break}
                # 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 "continue\n\}\n"
                append cgetbody $stmt
                append cgetbody "lappend result \[\$$target cget \[lindex [list $newformlist] \$index\]\]\n"
                append cgetbody "continue\n\}\n"
                
            }
        }
        
        proc defaultOption {cfgbodyVar cgetbodyVar} {
            upvar $cfgbodyVar cfgbody
            upvar $cgetbodyVar cgetbody
            variable unknowns
            if {[info exists unknowns(options)]} {
                append cfgbody "default \{\$$unknowns(options) configure \$option \$value\ncontinue\}\n"
                append cgetbody "default \{lappend result \[\$$unknowns(options) cget \$option\]\ncontinue\}\n"
            } else  {
                set dontKnow "default \{error \"unknown option '\$option'\"\}\n"
                append cfgbody $dontKnow
                append cgetbody $dontKnow
            }
            return
        }
        
        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 "[string map {result __result} $onget($option)]\n"
            }
            # the variable hanging to an option
            set name [string range $option 1 end]
            append body "lappend result \$$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 delegateMethod {args} {
            set method [lindex $args 0]
            set args [lrange $args 1 end]
            if {$method eq "*"} {
                # not yet implemented : delegate method * to <target>
                error "not yet implemented : delegate method * to ..."
                foreach {to target} $args {
                    variable unknowns
                    # set a target for delegating every (unknown) proc
                    set unkowns(method) $target
                    return
                }
            } 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}}
                namespace eval ::itins::eval [list method $method {args} "eval \$$target $newform \$args"]
            }
        }
        
        proc delegateOption {args} {
            set option [lindex $args 0]
            set args [lrange $args 1 end]
            if {[string equal $option *]} {
                variable unknowns
                foreach {to target} $args {break}
                testSet unknowns options $target "target for unknown options already defined"
                return
            }
            validateOption $option
            foreach {to target} $args {break}
            set newform $option
            catch {foreach {as newform} \
                        [set args [lrange $args 2 end]] {break}}
            variable delegatedOptions
            validateOption $newform
            AryLappend delegatedOptions $target $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 args} {
            upvar $arrayName arrayVar
            if {![info exists arrayVar($key)]} {
                set arrayVar($key) [lindex $args 0]
                set args [lrange $args 1 end]
            }
            foreach {value} $args {
                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
        }
        
        # create an arglist, avoiding the 'one-argument' mismatch
        proc lone {arglist} {
            if {[llength $arglist]!=1} {return [list $arglist]}
            return "\{$arglist\}"
        }
        
        # setonce : if already set, put an error
        proc setonce {var value {errmsg "internal error"}} {
            if {[catch {upvar $var a}]} {
                uplevel set $var $value
            } else  {
                error $errmsg
            }
            return
        }
        
        # getonce : get the value of the variable if it exists, otherwise return a default value
        proc getonce {var args} {
            if {[uplevel array exists $var]} {
                upvar $var table
                set key [lindex $args 0]
                set default [lindex $args 1]
                if {[info exists table($key)]} {
                    return $table($key)
                }
                return $default
            }
            catch {upvar $var a}
            if {![info exists a]} {
                return [lindex $args 0]
            }
            return $a
        }
        
        # 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
        }
        
        # return a list of the keys and a list of associated values
        proc pairs {list} {
            set odd ""
            set even ""
            foreach {key val} $list {
                lappend odd $key
                lappend even $val
            }
            return [list $odd $even]
        }
        
    }
    
    # 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 {eval itins::delegateMethod [lrange $args 1 end]}
                option {eval 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
        }
        
        # syntax : hull frame, hull toplevel
        ::proc hull {{cmd frame}} {
            if {!$::itins::isawidget} {
                error "hull command does not apply to a non-widget"
            }
            variable hull
            # PLEASE !!! DON'T MODIFY THIS !!! (there is some magic in it)
            # don't do that if you don't want to live the quoting hell
            method hull {} {
                rename $hull ::${hull}:cmd
                ::proc ::$hull {subcmd args} [string map [list %PATH% $this] {
                    return [eval [linsert $args 0 %PATH% $subcmd]]
                }]
                return $hull
            }
            itins::testSet itins::widgetHandle type $cmd "hull type already defined"
        }
        
        
        
        
        ::proc typeconstructor {body} {
            proc typeconstructor {} $body
            itins::testSet itins::specials typeconstructor yes "typeconstructor redefined"
        }
        ::proc option {name args} {
            itins::validateOption $name
            if {[llength $args]==0} {
                # noop
            } elseif {[llength $args]==1} {
                set default [lindex $args 0]
            } else  {
                foreach {option value} $args {
                    switch -exact -- $option {
                        -default {itins::setonce default $value "-default option repeated"}
                        -readonly   {itins::setonce readonly $value "-readonly option repeated"}
                    }
                }
            }
            lappend itins::nonDelegatedOptions $name [itins::getonce default ""] \
                    [itins::getonce readonly no]
        }
        
        ::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"
        }
    }
    # public aliases
    interp alias {} itins::delete {} itcl::delete object
    interp alias {} itins::scope {} itcl::scope
    interp alias {} itins::local {} itcl::local
    
    package provide itins 0.1
----
'''An example :'''

 package require itins
 
 
    itins::type Person {
        typevariable nbPersons 0
        variable name
        variable tool
        option -decorate no
        delegate option -setting to tool
        constructor {{myname "Steve McQueen"}} {
            set name $myname
            set tool [Tool #auto]
            incr nbPersons
            puts "Person named : '$name' created"
        }
        destructor {
            itins::delete $tool
            incr nbPersons -1
            puts "Person named : '$name' deleted"
        }
        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."
        }
        proc getNb {} {
            return $nbPersons
        }
        #test procs!
        proc Hello {what} {
            return "Hello $what!"
        }
    } Person.itcl
    source Person.itcl
    
    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'"
        }
    }
    
 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
 
'''A simple widget example :'''

    package require itins
    itins::widget Button {
        hull
        variable button
        option -packpad 10
        onconfigure -packpad {value} {
            pack configure $button -padx $value -pady $value
        }
        delegate option * to button
        
        constructor {args} {
            set button [button $hull.b -text "Click me"]
            pack $button -padx 10 -pady 10 -in $hull
            eval configure $args
        }
        destructor {
            catch {destroy $button}
        }
    }
    proc try {firstname name} {
        global btn
        tk_messageBox -message "Have you ever tried to look like $firstname $name?"
        destroy $btn
    }
    set btn [itins::wset Button .btn -text "Top Cool Language" -command {try Freddie Mercury}]
    # comment this when you've got a toplevel hull, of course
    pack $btn
    update
    $btn configure -packpad 15
    tk_messageBox -message "The button text is : [$btn cget -text]"
    



'''July 17, 2005''' [SRIV] When running the first example I get '''invalid command name "'''.
The second example fails when not using the "save to file" widget creation mode.
'''UPDATE:''' Heres some of the tweaks I had to make in order for it to work with no errors:
 itins.tcl:
 line 40:  eval itcl::class ::$className "\{\n$body\}"
 line 296: interp alias {} ::itins::delete {} ::itcl::delete object
 line 299: if {[llength $args] == 1} {set args [lindex $args 0]}

[SRIV] Wishlist of things I havent been able to figure out yet:
 try to eliminate the need for itins::wset
 add configure functionality where specifying no args returns all the current options, like real tk widgets


[PWQ] ''18 Jul 05'', I don't want to appear negative, but what is the point of an OO system on top of another OO system?

It's not. it uses pure tcl to modify the behavior of an OO system.

'''July 30, 2005''' [SRIV] It appears that[sarnold] has implemented my wishlist, Thanks!

Some notes on converting from Snit to itins:
   * Replace any occurace of $self with $this
   * In the constructor, replace "$self configurelist $args" with "eval configure $args"
   * Replace references to option values such as $option(-text) with $text
   * You must have a destructor otherwise theres an error. At least use "destructor {}"  

A pkgIndex.tcl file for itns:
 #pkgIndex.tcl for itins
 package ifneeded itins 0.2 [list source [file join $dir itins.tcl]]


----
[Category Object Orientation] [Category Package]