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

 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

    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]"

 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]}

 try to eliminate the need for itins::wset
 add configure functionality where specifying no args returns all the current options, like real tk widgets

• Replace any occurance of $self with $this
• In the constructor, replace "$self configurelist $args" with "eval configure $args" - Sarnold thinks that "configure $args" should be enough
• Replace references to option values such as $option(-text) with $text
• You must have a destructor otherwise itins throws an error. At least use "destructor {}"
• Do not create method names that are the same as a tcl command name in itins. Snit allows this though.

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

 Snit vs Itins : time spent in microseconds
 Test:			      Snit:   Itins:
 Creation and destruction:	   3052      162
 Method call (not delegated):	  84       14
 Method call (delegated):	      76       43
 Option setting:		      113       34
 Option setting (delegated):	  168       53
 Option getting:		       55       37
 Option getting (delegated):	  110       57

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References