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.1An 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 $tA 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 widgetsPWQ 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! Go grab the latest version from the url above.Some notes on converting from Snit to itins:
- Replace any occurrence 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]]
RLH 05-Sept-2005: Why layer a delegation system on top of incr Tcl instead of just using Snit? SRIV 05-Sept-2005: Speed. RLH And does it? Do you have benchmarks? Just curious. SRIV The source includes a benchmark app. Give it a try. DKF Have you tried building on top of xotcl? That's reputed to be faster than itcl... SRIV The appeal of itcl/itins is that its easy to convert my widgets from snit, and I have itcl available anyways, since I use tclkit exclusively. So for me, its small, fast and sufficiently functional. If your operating circumstances are different, ymmv. Sarnold 06-Sept-2005: Yes, and my Mandrake Discovery provides itcl, but not xotcl. Here are some benchmarks using a 766 Mhz processor under WindowsME:
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
