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!"
}
}
itins::type Toaster {
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}
method print {} {
puts -nonewline "My name is $name, and I am "
if {!$decorate} {
puts -nonewline "not "
}
puts "decorated."
puts "My tools settings are [cget -setting]."
return
}
method try {look} {
puts "I am trying to look at $look."
}
method whenBusy {{overclock no}} {
print
puts -nonewline "When I am busy, I do "
if {!$overclock} {
puts -nonewline "not "
}
puts "overclock my CPU."
}
#test procs!
proc Hello {what} {
puts "Hello $what!"
}
}
set t [Toaster #auto "Steve L. Justice"]
$t print
$t tell "This is the truth : I am a liar"
itins::delete $t
'July 11, 2005 SRIV There seems to be a missing method "tell" in the demo.