diff --git a/src/bootsupport/lib/control/control.tcl b/src/bootsupport/lib/control/control.tcl index 6cdf08a0..372f8ac1 100644 --- a/src/bootsupport/lib/control/control.tcl +++ b/src/bootsupport/lib/control/control.tcl @@ -4,7 +4,7 @@ # "control". It provides commands that govern the flow of # control of a program. -package require Tcl 8.2 +package require Tcl 8.5 9 namespace eval ::control { namespace export assert control do no-op rswitch @@ -20,5 +20,5 @@ namespace eval ::control { lappend ::auto_path $home } - package provide [namespace tail [namespace current]] 0.1.3 + package provide [namespace tail [namespace current]] 0.1.4 } diff --git a/src/bootsupport/lib/control/pkgIndex.tcl b/src/bootsupport/lib/control/pkgIndex.tcl index 3b432db7..e781098f 100644 --- a/src/bootsupport/lib/control/pkgIndex.tcl +++ b/src/bootsupport/lib/control/pkgIndex.tcl @@ -1,2 +1,2 @@ -if {![package vsatisfies [package provide Tcl] 8.2]} {return} -package ifneeded control 0.1.3 [list source [file join $dir control.tcl]] +if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} +package ifneeded control 0.1.4 [list source [file join $dir control.tcl]] diff --git a/src/bootsupport/lib/fileutil/decode.tcl b/src/bootsupport/lib/fileutil/decode.tcl new file mode 100644 index 00000000..341ac2a1 --- /dev/null +++ b/src/bootsupport/lib/fileutil/decode.tcl @@ -0,0 +1,207 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Copyright (c) 2008-2009 ActiveState Software Inc., Andreas Kupries +## 2016 Andreas Kupries +## BSD License +## +# Package to help the writing of file decoders. Provides generic +# low-level support commands. + +package require Tcl 8.5 9 + +namespace eval ::fileutil::decode { + namespace export mark go rewind at + namespace export byte short-le long-le nbytes skip + namespace export unsigned match recode getval + namespace export clear get put putloc setbuf +} + +# ### ### ### ######### ######### ######### +## + +proc ::fileutil::decode::open {fname} { + variable chan + set chan [::open $fname r] + fconfigure $chan \ + -translation binary \ + -encoding binary \ + -eofchar {} + return +} + +proc ::fileutil::decode::close {} { + variable chan + ::close $chan +} + +# ### ### ### ######### ######### ######### +## + +proc ::fileutil::decode::mark {} { + variable chan + variable mark + set mark [tell $chan] + return +} + +proc ::fileutil::decode::go {to} { + variable chan + seek $chan $to start + return +} + +proc ::fileutil::decode::rewind {} { + variable chan + variable mark + if {$mark == {}} { + return -code error \ + -errorcode {FILE DECODE NO MARK} \ + "No mark to rewind to" + } + seek $chan $mark start + set mark {} + return +} + +proc ::fileutil::decode::at {} { + variable chan + return [tell $chan] +} + +# ### ### ### ######### ######### ######### +## + +proc ::fileutil::decode::byte {} { + variable chan + variable mask 0xff + variable val [read $chan 1] + binary scan $val c val + return +} + +proc ::fileutil::decode::short-le {} { + variable chan + variable mask 0xffff + variable val [read $chan 2] + binary scan $val s val + return +} + +proc ::fileutil::decode::long-le {} { + variable chan + variable mask 0xffffffff + variable val [read $chan 4] + binary scan $val i val + return +} + +proc ::fileutil::decode::nbytes {n} { + variable chan + variable mask {} + variable val [read $chan $n] + return +} + +proc ::fileutil::decode::skip {n} { + variable chan + #read $chan $n + seek $chan $n current + return +} + +# ### ### ### ######### ######### ######### +## + +proc ::fileutil::decode::unsigned {} { + variable val + if {$val >= 0} return + variable mask + if {$mask eq {}} { + return -code error \ + -errorcode {FILE DECODE ILLEGAL UNSIGNED} \ + "Unsigned not possible here" + } + set val [format %u [expr {$val & $mask}]] + return +} + +proc ::fileutil::decode::match {eval} { + variable val + + #puts "Match: Expected $eval, Got: [format 0x%08x $val]" + + if {$val == $eval} {return 1} + rewind + return 0 +} + +proc ::fileutil::decode::recode {cmdpfx} { + variable val + lappend cmdpfx $val + set val [uplevel 1 $cmdpfx] + return +} + +proc ::fileutil::decode::getval {} { + variable val + return $val +} + +# ### ### ### ######### ######### ######### +## + +proc ::fileutil::decode::clear {} { + variable buf {} + return +} + +proc ::fileutil::decode::get {} { + variable buf + return $buf +} + +proc ::fileutil::decode::setbuf {list} { + variable buf $list + return +} + +proc ::fileutil::decode::put {name} { + variable buf + variable val + lappend buf $name $val + return +} + +proc ::fileutil::decode::putloc {name} { + variable buf + variable chan + lappend buf $name [tell $chan] + return +} + +# ### ### ### ######### ######### ######### +## + +namespace eval ::fileutil::decode { + # Stream to read from + variable chan {} + + # Last value read from the stream, or modified through decoder + # operations. + variable val {} + + # Remembered location in the stream + variable mark {} + + # Buffer for accumulating structured results + variable buf {} + + # Mask for trimming a value to unsigned. + # Size-dependent + variable mask {} +} + +# ### ### ### ######### ######### ######### +## Ready +package provide fileutil::decode 0.2.2 +return diff --git a/src/bootsupport/modules/fileutil-1.16.1.tm b/src/bootsupport/lib/fileutil/fileutil.tcl similarity index 85% rename from src/bootsupport/modules/fileutil-1.16.1.tm rename to src/bootsupport/lib/fileutil/fileutil.tcl index 6d5c737e..bb80f45b 100644 --- a/src/bootsupport/modules/fileutil-1.16.1.tm +++ b/src/bootsupport/lib/fileutil/fileutil.tcl @@ -9,9 +9,9 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require Tcl 8.5- +package require Tcl 8.5 9 package require cmdline -package provide fileutil 1.16.1 +package provide fileutil 1.16.2 namespace eval ::fileutil { namespace export \ @@ -196,237 +196,55 @@ proc ::fileutil::FADD {filename} { return } -# The next three helper commands for fileutil::find depend strongly on -# the version of Tcl, and partially on the platform. - -# 1. The -directory and -types switches were added to glob in Tcl -# 8.3. This means that we have to emulate them for Tcl 8.2. -# -# 2. In Tcl 8.3 using -types f will return only true files, but not -# links to files. This changed in 8.4+ where links to files are -# returned as well. So for 8.3 we have to handle the links -# separately (-types l) and also filter on our own. -# Note that Windows file links are hard links which are reported by -# -types f, but not -types l, so we can optimize that for the two -# platforms. -# -# Note further that we have to handle broken links on our own. They -# are not returned by glob yet we want them in the output. -# -# 3. In Tcl 8.3 we also have a crashing bug in glob (SIGABRT, "stat on -# a known file") when trying to perform 'glob -types {hidden f}' on -# a directory without e'x'ecute permissions. We code around by -# testing if we can cd into the directory (stat might return enough -# information too (mode), but possibly also not portable). -# -# For Tcl 8.2 and 8.4+ glob simply delivers an empty result -# (-nocomplain), without crashing. For them this command is defined -# so that the bytecode compiler removes it from the bytecode. -# -# This bug made the ACCESS helper necessary. -# We code around the problem by testing if we can cd into the -# directory (stat might return enough information too (mode), but -# possibly also not portable). - -if {[package vsatisfies [package present Tcl] 8.5]} { - # Tcl 8.5+. - # We have to check readability of "current" on our own, glob - # changed to error out instead of returning nothing. - - proc ::fileutil::ACCESS {args} {} - - proc ::fileutil::GLOBF {current} { - if {![file readable $current] || - [BadLink $current]} { - return {} - } - - set res [lsort -unique [concat \ - [glob -nocomplain -directory $current -types f -- *] \ - [glob -nocomplain -directory $current -types {hidden f} -- *]]] - - # Look for broken links (They are reported as neither file nor directory). - foreach l [lsort -unique [concat \ - [glob -nocomplain -directory $current -types l -- *] \ - [glob -nocomplain -directory $current -types {hidden l} -- *]]] { - if {[file isfile $l]} continue - if {[file isdirectory $l]} continue - lappend res $l - } - return [lsort -unique $res] - } - - proc ::fileutil::GLOBD {current} { - if {![file readable $current] || - [BadLink $current]} { - return {} - } - - lsort -unique [concat \ - [glob -nocomplain -directory $current -types d -- *] \ - [glob -nocomplain -directory $current -types {hidden d} -- *]] - } - - proc ::fileutil::BadLink {current} { - if {[file type $current] ne "link"} { return no } +# Tcl 8.5+. +# We have to check readability of "current" on our own, glob +# changed to error out instead of returning nothing. - set dst [file join [file dirname $current] [file readlink $current]] - - if {![file exists $dst] || - ![file readable $dst]} { - return yes - } +proc ::fileutil::ACCESS {args} {} - return no +proc ::fileutil::GLOBF {current} { + if {![file readable $current] || + [BadLink $current]} { + return {} } -} elseif {[package vsatisfies [package present Tcl] 8.4]} { - # Tcl 8.4+. - # (Ad 1) We have -directory, and -types, - # (Ad 2) Links are returned for -types f/d if they refer to files/dirs. - # (Ad 3) No bug to code around - - proc ::fileutil::ACCESS {args} {} - - proc ::fileutil::GLOBF {current} { - set res [lsort -unique [concat \ - [glob -nocomplain -directory $current -types f -- *] \ - [glob -nocomplain -directory $current -types {hidden f} -- *]]] - # Look for broken links (They are reported as neither file nor directory). - foreach l [lsort -unique [concat \ - [glob -nocomplain -directory $current -types l -- *] \ - [glob -nocomplain -directory $current -types {hidden l} -- *]]] { - if {[file isfile $l]} continue - if {[file isdirectory $l]} continue - lappend res $l - } - return [lsort -unique $res] - } + set res [lsort -unique [concat \ + [glob -nocomplain -directory $current -types f -- *] \ + [glob -nocomplain -directory $current -types {hidden f} -- *]]] - proc ::fileutil::GLOBD {current} { - lsort -unique [concat \ - [glob -nocomplain -directory $current -types d -- *] \ - [glob -nocomplain -directory $current -types {hidden d} -- *]] + # Look for broken links (They are reported as neither file nor directory). + foreach l [lsort -unique [concat \ + [glob -nocomplain -directory $current -types l -- *] \ + [glob -nocomplain -directory $current -types {hidden l} -- *]]] { + if {[file isfile $l]} continue + if {[file isdirectory $l]} continue + lappend res $l } + return [lsort -unique $res] +} -} elseif {[package vsatisfies [package present Tcl] 8.3]} { - # 8.3. - # (Ad 1) We have -directory, and -types, - # (Ad 2) Links are NOT returned for -types f/d, collect separately. - # No symbolic file links on Windows. - # (Ad 3) Bug to code around. - - proc ::fileutil::ACCESS {current} { - if {[catch { - set h [pwd] ; cd $current ; cd $h - }]} {return -code continue} - return +proc ::fileutil::GLOBD {current} { + if {![file readable $current] || + [BadLink $current]} { + return {} } - if {[string equal $::tcl_platform(platform) windows]} { - proc ::fileutil::GLOBF {current} { - concat \ - [glob -nocomplain -directory $current -types f -- *] \ - [glob -nocomplain -directory $current -types {hidden f} -- *]] - } - } else { - proc ::fileutil::GLOBF {current} { - set l [concat \ - [glob -nocomplain -directory $current -types f -- *] \ - [glob -nocomplain -directory $current -types {hidden f} -- *]] - - foreach x [concat \ - [glob -nocomplain -directory $current -types l -- *] \ - [glob -nocomplain -directory $current -types {hidden l} -- *]] { - if {[file isdirectory $x]} continue - # We have now accepted files, links to files, and broken links. - lappend l $x - } - - return $l - } - } + lsort -unique [concat \ + [glob -nocomplain -directory $current -types d -- *] \ + [glob -nocomplain -directory $current -types {hidden d} -- *]] +} - proc ::fileutil::GLOBD {current} { - set l [concat \ - [glob -nocomplain -directory $current -types d -- *] \ - [glob -nocomplain -directory $current -types {hidden d} -- *]] +proc ::fileutil::BadLink {current} { + if {[file type $current] ne "link"} { return no } - foreach x [concat \ - [glob -nocomplain -directory $current -types l -- *] \ - [glob -nocomplain -directory $current -types {hidden l} -- *]] { - if {![file isdirectory $x]} continue - lappend l $x - } + set dst [file join [file dirname $current] [file readlink $current]] - return $l + if {![file exists $dst] || + ![file readable $dst]} { + return yes } -} else { - # 8.2. - # (Ad 1,2,3) We do not have -directory, nor -types. Full emulation required. - - proc ::fileutil::ACCESS {args} {} - - if {[string equal $::tcl_platform(platform) windows]} { - # Hidden files cannot be handled by Tcl 8.2 in glob. We have - # to punt. - - proc ::fileutil::GLOBF {current} { - set current \\[join [split $current {}] \\] - set res {} - foreach x [glob -nocomplain -- [file join $current *]] { - if {[file isdirectory $x]} continue - if {[catch {file type $x}]} continue - # We have now accepted files, links to files, and - # broken links. We may also have accepted a directory - # as well, if the current path was inaccessible. This - # however will cause 'file type' to throw an error, - # hence the second check. - lappend res $x - } - return $res - } - - proc ::fileutil::GLOBD {current} { - set current \\[join [split $current {}] \\] - set res {} - foreach x [glob -nocomplain -- [file join $current *]] { - if {![file isdirectory $x]} continue - lappend res $x - } - return $res - } - } else { - # Hidden files on Unix are dot-files. We emulate the switch - # '-types hidden' by using an explicit pattern. - - proc ::fileutil::GLOBF {current} { - set current \\[join [split $current {}] \\] - set res {} - foreach x [glob -nocomplain -- [file join $current *] [file join $current .*]] { - if {[file isdirectory $x]} continue - if {[catch {file type $x}]} continue - # We have now accepted files, links to files, and - # broken links. We may also have accepted a directory - # as well, if the current path was inaccessible. This - # however will cause 'file type' to throw an error, - # hence the second check. - - lappend res $x - } - return $res - } - proc ::fileutil::GLOBD {current} { - set current \\[join [split $current {}] \\] - set res {} - foreach x [glob -nocomplain -- $current/* [file join $current .*]] { - if {![file isdirectory $x]} continue - lappend res $x - } - return $res - } - } + return no } # ::fileutil::findByPattern -- @@ -1459,56 +1277,50 @@ proc ::fileutil::foreachLine {var filename cmd} { # Errors: # Both of "-r" and "-t" cannot be specified. -if {[package vsatisfies [package provide Tcl] 8.3]} { - namespace eval ::fileutil { - namespace export touch - } - - proc ::fileutil::touch {args} { - # Don't bother catching errors, just let them propagate up +proc ::fileutil::touch {args} { + # Don't bother catching errors, just let them propagate up - set options { - {a "set the atime only"} - {m "set the mtime only"} - {c "do not create non-existant files"} - {r.arg "" "use time from ref_file"} - {t.arg -1 "use specified time"} - } - set usage ": [lindex [info level 0] 0]\ + set options { + {a "set the atime only"} + {m "set the mtime only"} + {c "do not create non-existant files"} + {r.arg "" "use time from ref_file"} + {t.arg -1 "use specified time"} + } + set usage ": [lindex [info level 0] 0]\ \[options] filename ...\noptions:" - array set params [::cmdline::getoptions args $options $usage] - - # process -a and -m options - set set_atime [set set_mtime "true"] - if { $params(a) && ! $params(m)} {set set_mtime "false"} - if {! $params(a) && $params(m)} {set set_atime "false"} - - # process -r and -t - set has_t [expr {$params(t) != -1}] - set has_r [expr {[string length $params(r)] > 0}] - if {$has_t && $has_r} { - return -code error "Cannot specify both -r and -t" - } elseif {$has_t} { - set atime [set mtime $params(t)] - } elseif {$has_r} { - file stat $params(r) stat - set atime $stat(atime) - set mtime $stat(mtime) - } else { - set atime [set mtime [clock seconds]] - } + array set params [::cmdline::getoptions args $options $usage] - # do it - foreach filename $args { - if {! [file exists $filename]} { - if {$params(c)} {continue} - close [open $filename w] - } - if {$set_atime} {file atime $filename $atime} - if {$set_mtime} {file mtime $filename $mtime} + # process -a and -m options + set set_atime [set set_mtime "true"] + if { $params(a) && ! $params(m)} {set set_mtime "false"} + if {! $params(a) && $params(m)} {set set_atime "false"} + + # process -r and -t + set has_t [expr {$params(t) != -1}] + set has_r [expr {[string length $params(r)] > 0}] + if {$has_t && $has_r} { + return -code error "Cannot specify both -r and -t" + } elseif {$has_t} { + set atime [set mtime $params(t)] + } elseif {$has_r} { + file stat $params(r) stat + set atime $stat(atime) + set mtime $stat(mtime) + } else { + set atime [set mtime [clock seconds]] + } + + # do it + foreach filename $args { + if {! [file exists $filename]} { + if {$params(c)} {continue} + close [open $filename w] } - return + if {$set_atime} {file atime $filename $atime} + if {$set_mtime} {file mtime $filename $mtime} } + return } # ::fileutil::fileType -- @@ -1921,7 +1733,7 @@ proc ::fileutil::MakeTempDir {config} { if {[catch { file mkdir $path if {$::tcl_platform(platform) eq "unix"} { - file attributes $path -permissions 0700 + file attributes $path -permissions 0o700 } }]} continue diff --git a/src/bootsupport/lib/fileutil/multi.tcl b/src/bootsupport/lib/fileutil/multi.tcl new file mode 100644 index 00000000..757b83ed --- /dev/null +++ b/src/bootsupport/lib/fileutil/multi.tcl @@ -0,0 +1,28 @@ +# ### ### ### ######### ######### ######### +## +# (c) 2007 Andreas Kupries. + +# Multi file operations. Singleton based on the multiop processor. + +# ### ### ### ######### ######### ######### +## Requisites + +package require fileutil::multi::op + +# ### ### ### ######### ######### ######### +## API & Implementation + +namespace eval ::fileutil {} + +# Create the multiop processor object and make its do method the main +# command of this package. +::fileutil::multi::op ::fileutil::multi::obj + +proc ::fileutil::multi {args} { + return [uplevel 1 [linsert $args 0 ::fileutil::multi::obj do]] +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide fileutil::multi 0.2 diff --git a/src/bootsupport/lib/fileutil/multiop.tcl b/src/bootsupport/lib/fileutil/multiop.tcl new file mode 100644 index 00000000..72a9e5b0 --- /dev/null +++ b/src/bootsupport/lib/fileutil/multiop.tcl @@ -0,0 +1,645 @@ +# ### ### ### ######### ######### ######### +## +# (c) 2007-2008 Andreas Kupries. + +# DSL allowing the easy specification of multi-file copy and/or move +# and/or deletion operations. Alternate names would be scatter/gather +# processor, or maybe even assembler. + +# Examples: +# (1) copy +# into [installdir_of tls] +# from c:/TDK/PrivateOpenSSL/bin +# the *.dll +# +# (2) move +# from /sources +# into /scratch +# the * +# but not *.html +# (Alternatively: except for *.html) +# +# (3) into /scratch +# from /sources +# move +# as pkgIndex.tcl +# the index +# +# (4) in /scratch +# remove +# the *.txt + +# The language is derived from the parts of TclApp's option language +# dealing with files and their locations, yet not identical. In parts +# simplified, in parts more capable, keyword names were changed +# throughout. + +# Language commands + +# From the examples +# +# into DIR : Specify destination directory. +# in DIR : See 'into'. +# from DIR : Specify source directory. +# the PATTERN (...) : Specify files to operate on. +# but not PATTERN : Specify exceptions to 'the'. +# but exclude PATTERN : Specify exceptions to 'the'. +# except for PATTERN : See 'but not'. +# as NAME : New name for file. +# move : Move files. +# copy : Copy files. +# remove : Delete files. +# +# Furthermore +# +# reset : Force to defaults. +# cd DIR : Change destination to subdirectory. +# up : Change destination to parent directory. +# ( : Save a copy of the current state. +# ) : Restore last saved state and make it current. + +# The main active element is the command 'the'. In other words, this +# command not only specifies the files to operate on, but also +# executes the operation as defined in the current state. All other +# commands modify the state to set the operation up, and nothing +# else. To allow for a more natural syntax the active command also +# looks ahead for the commands 'as', 'but', and 'except', and executes +# them, like qualifiers, so that they take effect as if they had been +# written before. The command 'but' and 'except use identical +# constructions to handle their qualifiers, i.e. 'not' and 'for'. + +# Note that the fact that most commands just modify the state allows +# us to use more off forms as specifications instead of just natural +# language sentences For example the example 2 can re-arranged into: +# +# (5) from /sources +# into /scratch +# but not *.html +# move +# the * +# +# and the result is still a valid specification. + +# Further note that the information collected by 'but', 'except', and +# 'as' is automatically reset after the associated 'the' was +# executed. However no other state is reset in that manner, allowing +# the user to avoid repetitions of unchanging information. Lets us for +# example merge the examples 2 and 3. The trivial merge is: + +# (6) move +# into /scratch +# from /sources +# the * +# but not *.html not index +# move +# into /scratch +# from /sources +# the index +# as pkgIndex.tcl +# +# With less repetitions +# +# (7) move +# into /scratch +# from /sources +# the * +# but not *.html not index +# the index +# as pkgIndex.tcl + +# I have not yet managed to find a suitable syntax to specify when to +# add a new extension to the moved/copied files, or have to strip all +# extensions, a specific extension, or even replace extensions. + +# Other possibilities to muse about: Load the patterns for 'not'/'for' +# from a file ... Actually, load the whole exceptions from a file, +# with its contents a proper interpretable word list. Which makes it +# general processing of include files. + +# ### ### ### ######### ######### ######### +## Requisites + +# This processor uses the 'wip' word list interpreter as its +# foundation. + +package require fileutil ; # File testing +package require snit ; # OO support +package require struct::stack ; # Context stack +package require wip ; # DSL execution core + +# ### ### ### ######### ######### ######### +## API & Implementation + +snit::type ::fileutil::multi::op { + # ### ### ### ######### ######### ######### + ## API + + constructor {args} {} ; # create processor + + # ### ### ### ######### ######### ######### + ## API - Implementation. + + constructor {args} { + install stack using struct::stack ${selfns}::stack + $self wip_setup + + # Mapping dsl commands to methods. + defdva \ + reset Reset ( Push ) Pop \ + into Into in Into from From \ + cd ChDir up ChUp as As \ + move Move copy Copy remove Remove \ + but But not Exclude the The \ + except Except for Exclude exclude Exclude \ + to Into -> Save the-set TheSet \ + recursive Recursive recursively Recursive \ + for-win ForWindows for-unix ForUnix \ + for-windows ForWindows expand Expand \ + invoke Invoke strict Strict !strict NotStrict \ + files Files links Links all Everything \ + dirs Directories directories Directories \ + state? QueryState from? QueryFrom into? QueryInto \ + excluded? QueryExcluded as? QueryAs type? QueryType \ + recursive? QueryRecursive operation? QueryOperation \ + strict? QueryStrict !recursive NotRecursive + + $self Reset + runl $args + return + } + + destructor { + $mywip destroy + return + } + + method do {args} { + return [runl $args] + } + + # ### ### ### ######### ######### ######### + ## DSL Implementation + wip::dsl + + # General reset of processor state + method Reset {} { + $stack clear + set base "" + set alias "" + set op "" + set recursive 0 + set src "" + set excl "" + set types {} + set strict 0 + return + } + + # Stack manipulation + method Push {} { + $stack push [list $base $alias $op $opcmd $recursive $src $excl $types $strict] + return + } + + method Pop {} { + if {![$stack size]} { + return -code error {Stack underflow} + } + foreach {base alias op opcmd recursive src excl types strict} [$stack pop] break + return + } + + # Destination directory + method Into {dir} { + if {$dir eq ""} {set dir [pwd]} + if {$strict && ![fileutil::test $dir edr msg {Destination directory}]} { + return -code error $msg + } + set base $dir + return + } + + method ChDir {dir} { $self Into [file join $base $dir] ; return } + method ChUp {} { $self Into [file dirname $base] ; return } + + # Detail + method As {fname} { + set alias [ForceRelative $fname] + return + } + + # Operations + method Move {} { set op move ; return } + method Copy {} { set op copy ; return } + method Remove {} { set op remove ; return } + method Expand {} { set op expand ; return } + + method Invoke {cmdprefix} { + set op invoke + set opcmd $cmdprefix + return + } + + # Operation qualifier + method Recursive {} { set recursive 1 ; return } + method NotRecursive {} { set recursive 0 ; return } + + # Source directory + method From {dir} { + if {$dir eq ""} {set dir [pwd]} + if {![fileutil::test $dir edr msg {Source directory}]} { + return -code error $msg + } + set src $dir + return + } + + # Exceptions + method But {} { run_next_while {not exclude} ; return } + method Except {} { run_next_while {for} ; return } + + method Exclude {pattern} { + lappend excl $pattern + return + } + + # Define the files to operate on, and perform the operation. + method The {pattern} { + run_next_while {as but except exclude from into in to files dirs directories links all} + + switch -exact -- $op { + invoke {Invoke [Resolve [Remember [Exclude [Expand $src $pattern]]]]} + move {Move [Resolve [Remember [Exclude [Expand $src $pattern]]]]} + copy {Copy [Resolve [Remember [Exclude [Expand $src $pattern]]]]} + remove {Remove [Remember [Exclude [Expand $base $pattern]]] } + expand { Remember [Exclude [Expand $base $pattern]] } + } + + # Reset the per-pattern flags of the resolution context back + # to their defaults, for the next pattern. + + set alias {} + set excl {} + set recursive 0 + return + } + + # Like 'The' above, except that the fileset is taken from the + # specified variable. Semi-complementary to 'Save' below. + # Exclusion data and recursion info do not apply for this, this is + # already implicitly covered by the set, when it was generated. + + method TheSet {varname} { + # See 'Save' for the levels we jump here. + upvar 5 $varname var + + run_next_while {as from into in to} + + switch -exact -- $op { + invoke {Invoke [Resolve $var]} + move {Move [Resolve $var]} + copy {Copy [Resolve $var]} + remove {Remove $var } + expand { + return -code error "Expansion does not make sense\ + when we already have a set of files." + } + } + + # Reset the per-pattern flags of the resolution context back + # to their defaults, for the next pattern. + + set alias {} + return + } + + # Save the last expansion result to a variable for use by future commands. + + method Save {varname} { + # Levels to jump. Brittle. + # 5: Caller + # 4: object do ... + # 3: runl + # 2: wip::runl + # 1: run_next + # 0: Here + upvar 5 $varname v + set v $lastexpansion + return + } + + # Platform conditionals ... + + method ForUnix {} { + global tcl_platform + if {$tcl_platform(platform) eq "unix"} return + # Kill the remaining code. This effectively aborts processing. + replacel {} + return + } + + method ForWindows {} { + global tcl_platform + if {$tcl_platform(platform) eq "windows"} return + # Kill the remaining code. This effectively aborts processing. + replacel {} + return + } + + # Strictness + + method Strict {} { + set strict 1 + return + } + + method NotStrict {} { + set strict 0 + return + } + + # Type qualifiers + + method Files {} { + set types files + return + } + + method Links {} { + set types links + return + } + + method Directories {} { + set types dirs + return + } + + method Everything {} { + set types {} + return + } + + # State interogation + + method QueryState {} { + return [list \ + from $src \ + into $base \ + as $alias \ + op $op \ + excluded $excl \ + recursive $recursive \ + type $types \ + strict $strict \ + ] + } + method QueryExcluded {} { + return $excl + } + method QueryFrom {} { + return $src + } + method QueryInto {} { + return $base + } + method QueryAs {} { + return $alias + } + method QueryOperation {} { + return $op + } + method QueryRecursive {} { + return $recursive + } + method QueryType {} { + return $types + } + method QueryStrict {} { + return $strict + } + + # ### ### ### ######### ######### ######### + ## DSL State + + component stack ; # State stack - ( ) + variable base "" ; # Destination dir - into, in, cd, up + variable alias "" ; # Detail - as + variable op "" ; # Operation - move, copy, remove, expand, invoke + variable opcmd "" ; # Command prefix for invoke. + variable recursive 0 ; # Op. qualifier: recursive expansion? + variable src "" ; # Source dir - from + variable excl "" ; # Excluded files - but not|exclude, except for + # incl ; # Included files - the (immediate use) + variable types {} ; # Limit glob/find to specific types (f, l, d). + variable strict 0 ; # Strictness of into/Expand + + variable lastexpansion "" ; # Area for last expansion result, for 'Save' to take from. + + # ### ### ### ######### ######### ######### + ## Internal -- Path manipulation helpers. + + proc ForceRelative {path} { + set pathtype [file pathtype $path] + switch -exact -- $pathtype { + relative { + return $path + } + absolute { + # Chop off the first element in the path, which is the + # root, either '/' or 'x:/'. If this was the only + # element assume an empty path. + + set path [lrange [file split $path] 1 end] + if {![llength $path]} {return {}} + return [eval [linsert $path 0 file join]] + } + volumerelative { + return -code error {Unable to handle volumerelative path, yet} + } + } + + return -code error \ + "file pathtype returned unknown type \"$pathtype\"" + } + + proc ForceAbsolute {path} { + return [file join [pwd] $path] + } + + # ### ### ### ######### ######### ######### + ## Internal - Operation execution helpers + + proc Invoke {files} { + upvar 1 base base src src opcmd opcmd + uplevel #0 [linsert $opcmd end $src $base $files] + return + } + + proc Move {files} { + upvar 1 base base src src + + foreach {s d} $files { + set s [file join $src $s] + set d [file join $base $d] + + file mkdir [file dirname $d] + file rename -force $s $d + } + return + } + + proc Copy {files} { + upvar 1 base base src src + + foreach {s d} $files { + set s [file join $src $s] + set d [file join $base $d] + + file mkdir [file dirname $d] + if { + [file isdirectory $s] && + [file exists $d] && + [file isdirectory $d] + } { + # Special case: source and destination are + # directories, and the latter exists. This puts the + # source under the destination, and may even prevent + # copying at all. The semantics of the operation is + # that the source is the destination. We avoid the + # trouble by copying the contents of the source, + # instead of the directory itself. + foreach path [glob -directory $s *] { + file copy -force $path $d + } + } else { + file copy -force $s $d + } + } + return + } + + proc Remove {files} { + upvar 1 base base + + foreach f $files { + file delete -force [file join $base $f] + } + return + } + + # ### ### ### ######### ######### ######### + ## Internal -- Resolution helper commands + + typevariable tmap -array { + files {f TFile} + links {l TLink} + dirs {d TDir} + {} {{} {}} + } + + proc Expand {dir pattern} { + upvar 1 recursive recursive strict strict types types tmap tmap + # FUTURE: struct::list filter ... + + set files {} + if {$recursive} { + # Recursion through the entire directory hierarchy, save + # all matching paths. + + set filter [lindex $tmap($types) 1] + if {$filter ne ""} { + set filter [myproc $filter] + } + + foreach f [fileutil::find $dir $filter] { + if {![string match $pattern [file tail $f]]} continue + lappend files [fileutil::stripPath $dir $f] + } + } else { + # No recursion, just scan the whole directory for matching paths. + # check for specific types integrated. + + set filter [lindex $tmap($types) 0] + if {$filter ne ""} { + foreach f [glob -nocomplain -directory $dir -types $filter -- $pattern] { + lappend files [fileutil::stripPath $dir $f] + } + } else { + foreach f [glob -nocomplain -directory $dir -- $pattern] { + lappend files [fileutil::stripPath $dir $f] + } + } + } + + if {[llength $files]} {return $files} + if {!$strict} {return {}} + + return -code error \ + "No files matching pattern \"$pattern\" in directory \"$dir\"" + } + + proc TFile {f} {file isfile $f} + proc TDir {f} {file isdirectory $f} + proc TLink {f} {expr {[file type $f] eq "link"}} + + proc Exclude {files} { + upvar 1 excl excl + + # FUTURE: struct::list filter ... + set res {} + foreach f $files { + if {[IsExcluded $f $excl]} continue + lappend res $f + } + return $res + } + + proc IsExcluded {f patterns} { + foreach p $patterns { + if {[string match $p $f]} {return 1} + } + return 0 + } + + proc Resolve {files} { + upvar 1 alias alias + set res {} + foreach f $files { + + # Remember alias for processing and auto-invalidate to + # prevent contamination of the next file. + + set thealias $alias + set alias "" + + if {$thealias eq ""} { + set d $f + } else { + set d [file dirname $f] + if {$d eq "."} { + set d $thealias + } else { + set d [file join $d $thealias] + } + } + + lappend res $f $d + } + return $res + } + + proc Remember {files} { + upvar 1 lastexpansion lastexpansion + set lastexpansion $files + return $files + } + + ## + # ### ### ### ######### ######### ######### +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide fileutil::multi::op 0.5.4 diff --git a/src/bootsupport/modules/fileutil/paths-1.tm b/src/bootsupport/lib/fileutil/paths.tcl similarity index 95% rename from src/bootsupport/modules/fileutil/paths-1.tm rename to src/bootsupport/lib/fileutil/paths.tcl index e387acf7..107b239e 100644 --- a/src/bootsupport/modules/fileutil/paths-1.tm +++ b/src/bootsupport/lib/fileutil/paths.tcl @@ -12,7 +12,7 @@ # ### ### ### ######### ######### ######### ## Requisites -package require Tcl 8.4 +package require Tcl 8.5 9 package require snit # ### ### ### ######### ######### ######### @@ -70,5 +70,5 @@ snit::type ::fileutil::paths { # ### ### ### ######### ######### ######### ## Ready -package provide fileutil::paths 1 +package provide fileutil::paths 1.1 return diff --git a/src/bootsupport/lib/fileutil/pkgIndex.tcl b/src/bootsupport/lib/fileutil/pkgIndex.tcl new file mode 100644 index 00000000..29bb2fec --- /dev/null +++ b/src/bootsupport/lib/fileutil/pkgIndex.tcl @@ -0,0 +1,7 @@ +if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} +package ifneeded fileutil 1.16.2 [list source [file join $dir fileutil.tcl]] +package ifneeded fileutil::traverse 0.7 [list source [file join $dir traverse.tcl]] +package ifneeded fileutil::multi 0.2 [list source [file join $dir multi.tcl]] +package ifneeded fileutil::multi::op 0.5.4 [list source [file join $dir multiop.tcl]] +package ifneeded fileutil::decode 0.2.2 [list source [file join $dir decode.tcl]] +package ifneeded fileutil::paths 1.1 [list source [file join $dir paths.tcl]] diff --git a/src/bootsupport/modules/fileutil/traverse-0.6.tm b/src/bootsupport/lib/fileutil/traverse.tcl similarity index 63% rename from src/bootsupport/modules/fileutil/traverse-0.6.tm rename to src/bootsupport/lib/fileutil/traverse.tcl index 2f36d109..6d8fd8eb 100644 --- a/src/bootsupport/modules/fileutil/traverse-0.6.tm +++ b/src/bootsupport/lib/fileutil/traverse.tcl @@ -7,10 +7,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require Tcl 8.3 +package require Tcl 8.5 9 # OO core -if {[package vsatisfies [package present Tcl] 8.5]} { +if {[package vsatisfies [package present Tcl] 8.5 9]} { # Use new Tcl 8.5a6+ features to specify the allowed packages. # We can use anything above 1.3. This means v2 as well. package require snit 1.3- @@ -336,169 +336,58 @@ snit::type ::fileutil::traverse { # ### ### ### ######### ######### ######### ## -# The next three helper commands for the traverser depend strongly on -# the version of Tcl, and partially on the platform. +# Tcl 8.5+. +# We have to check readability of "current" on our own, glob +# changed to error out instead of returning nothing. -# 1. In Tcl 8.3 using -types f will return only true files, but not -# links to files. This changed in 8.4+ where links to files are -# returned as well. So for 8.3 we have to handle the links -# separately (-types l) and also filter on our own. -# Note that Windows file links are hard links which are reported by -# -types f, but not -types l, so we can optimize that for the two -# platforms. -# -# 2. In Tcl 8.3 we also have a crashing bug in glob (SIGABRT, "stat on -# a known file") when trying to perform 'glob -types {hidden f}' on -# a directory without e'x'ecute permissions. We code around by -# testing if we can cd into the directory (stat might return enough -# information too (mode), but possibly also not portable). -# -# For Tcl 8.2 and 8.4+ glob simply delivers an empty result -# (-nocomplain), without crashing. For them this command is defined -# so that the bytecode compiler removes it from the bytecode. -# -# This bug made the ACCESS helper necessary. -# We code around the problem by testing if we can cd into the -# directory (stat might return enough information too (mode), but -# possibly also not portable). - -if {[package vsatisfies [package present Tcl] 8.5]} { - # Tcl 8.5+. - # We have to check readability of "current" on our own, glob - # changed to error out instead of returning nothing. - - proc ::fileutil::traverse::ACCESS {args} {return 1} - - proc ::fileutil::traverse::GLOBF {current} { - if {![file readable $current] || - [BadLink $current]} { - return {} - } - - set res [lsort -unique [concat \ - [glob -nocomplain -directory $current -types f -- *] \ - [glob -nocomplain -directory $current -types {hidden f} -- *]]] - - # Look for broken links (They are reported as neither file nor directory). - foreach l [lsort -unique [concat \ - [glob -nocomplain -directory $current -types l -- *] \ - [glob -nocomplain -directory $current -types {hidden l} -- *]]] { - if {[file isfile $l]} continue - if {[file isdirectory $l]} continue - lappend res $l - } - return [lsort -unique $res] - } +proc ::fileutil::traverse::ACCESS {args} {return 1} - proc ::fileutil::traverse::GLOBD {current} { - if {![file readable $current] || - [BadLink $current]} { - return {} - } - - lsort -unique [concat \ - [glob -nocomplain -directory $current -types d -- *] \ - [glob -nocomplain -directory $current -types {hidden d} -- *]] +proc ::fileutil::traverse::GLOBF {current} { + if {![file readable $current] || + [BadLink $current]} { + return {} } - proc ::fileutil::traverse::BadLink {current} { - if {[file type $current] ne "link"} { return no } - - set dst [file join [file dirname $current] [file readlink $current]] - - if {![file exists $dst] || - ![file readable $dst]} { - return yes - } - - return no + set res [lsort -unique [concat \ + [glob -nocomplain -directory $current -types f -- *] \ + [glob -nocomplain -directory $current -types {hidden f} -- *]]] + + # Look for broken links (They are reported as neither file nor directory). + foreach l [lsort -unique [concat \ + [glob -nocomplain -directory $current -types l -- *] \ + [glob -nocomplain -directory $current -types {hidden l} -- *]]] { + if {[file isfile $l]} continue + if {[file isdirectory $l]} continue + lappend res $l } + return [lsort -unique $res] +} -} elseif {[package vsatisfies [package present Tcl] 8.4]} { - # Tcl 8.4+. - # (Ad 1) We have -directory, and -types, - # (Ad 2) Links are returned for -types f/d if they refer to files/dirs. - # (Ad 3) No bug to code around - - proc ::fileutil::traverse::ACCESS {args} {return 1} - - proc ::fileutil::traverse::GLOBF {current} { - set res [concat \ - [glob -nocomplain -directory $current -types f -- *] \ - [glob -nocomplain -directory $current -types {hidden f} -- *]] - - # Look for broken links (They are reported as neither file nor directory). - foreach l [concat \ - [glob -nocomplain -directory $current -types l -- *] \ - [glob -nocomplain -directory $current -types {hidden l} -- *] ] { - if {[file isfile $l]} continue - if {[file isdirectory $l]} continue - lappend res $l - } - return $res +proc ::fileutil::traverse::GLOBD {current} { + if {![file readable $current] || + [BadLink $current]} { + return {} } - proc ::fileutil::traverse::GLOBD {current} { - concat \ - [glob -nocomplain -directory $current -types d -- *] \ - [glob -nocomplain -directory $current -types {hidden d} -- *] - } + lsort -unique [concat \ + [glob -nocomplain -directory $current -types d -- *] \ + [glob -nocomplain -directory $current -types {hidden d} -- *]] +} -} else { - # 8.3. - # (Ad 1) We have -directory, and -types, - # (Ad 2) Links are NOT returned for -types f/d, collect separately. - # No symbolic file links on Windows. - # (Ad 3) Bug to code around. - - proc ::fileutil::traverse::ACCESS {current} { - if {[catch { - set h [pwd] ; cd $current ; cd $h - }]} {return 0} - return 1 - } +proc ::fileutil::traverse::BadLink {current} { + if {[file type $current] ne "link"} { return no } - if {[string equal $::tcl_platform(platform) windows]} { - proc ::fileutil::traverse::GLOBF {current} { - concat \ - [glob -nocomplain -directory $current -types f -- *] \ - [glob -nocomplain -directory $current -types {hidden f} -- *]] - } - } else { - proc ::fileutil::traverse::GLOBF {current} { - set l [concat \ - [glob -nocomplain -directory $current -types f -- *] \ - [glob -nocomplain -directory $current -types {hidden f} -- *]] - - foreach x [concat \ - [glob -nocomplain -directory $current -types l -- *] \ - [glob -nocomplain -directory $current -types {hidden l} -- *]] { - if {[file isdirectory $x]} continue - # We have now accepted files, links to files, and broken links. - lappend l $x - } + set dst [file join [file dirname $current] [file readlink $current]] - return $l - } + if {![file exists $dst] || + ![file readable $dst]} { + return yes } - proc ::fileutil::traverse::GLOBD {current} { - set l [concat \ - [glob -nocomplain -directory $current -types d -- *] \ - [glob -nocomplain -directory $current -types {hidden d} -- *]] - - foreach x [concat \ - [glob -nocomplain -directory $current -types l -- *] \ - [glob -nocomplain -directory $current -types {hidden l} -- *]] { - if {![file isdirectory $x]} continue - lappend l $x - } - - return $l - } + return no } # ### ### ### ######### ######### ######### ## Ready -package provide fileutil::traverse 0.6 +package provide fileutil::traverse 0.7 diff --git a/src/bootsupport/lib/snit/main1.tcl b/src/bootsupport/lib/snit/main1.tcl new file mode 100644 index 00000000..9cbe4805 --- /dev/null +++ b/src/bootsupport/lib/snit/main1.tcl @@ -0,0 +1,3987 @@ +#----------------------------------------------------------------------- +# TITLE: +# main1.tcl +# +# AUTHOR: +# Will Duquette +# +# DESCRIPTION: +# Snit's Not Incr Tcl, a simple object system in Pure Tcl. +# +# Snit 1.x Compiler and Run-Time Library, Tcl 8.4 and later +# +# Copyright (C) 2003-2006 by William H. Duquette +# This code is licensed as described in license.txt. +# +#----------------------------------------------------------------------- + +#----------------------------------------------------------------------- +# Namespace + +namespace eval ::snit:: { + namespace export \ + compile type widget widgetadaptor typemethod method macro +} + +#----------------------------------------------------------------------- +# Some Snit variables + +namespace eval ::snit:: { + variable reservedArgs {type selfns win self} + + # Widget classes which can be hulls (must have -class) + variable hulltypes { + toplevel tk::toplevel + frame tk::frame ttk::frame + labelframe tk::labelframe ttk::labelframe + } +} + +#----------------------------------------------------------------------- +# Snit Type Implementation template + +namespace eval ::snit:: { + # Template type definition: All internal and user-visible Snit + # implementation code. + # + # The following placeholders will automatically be replaced with + # the client's code, in two passes: + # + # First pass: + # %COMPILEDDEFS% The compiled type definition. + # + # Second pass: + # %TYPE% The fully qualified type name. + # %IVARDECS% Instance variable declarations + # %TVARDECS% Type variable declarations + # %TCONSTBODY% Type constructor body + # %INSTANCEVARS% The compiled instance variable initialization code. + # %TYPEVARS% The compiled type variable initialization code. + + # This is the overall type template. + variable typeTemplate + + # This is the normal type proc + variable nominalTypeProc + + # This is the "-hastypemethods no" type proc + variable simpleTypeProc +} + +set ::snit::typeTemplate { + + #------------------------------------------------------------------- + # The type's namespace definition and the user's type variables + + namespace eval %TYPE% {%TYPEVARS% + } + + #---------------------------------------------------------------- + # Commands for use in methods, typemethods, etc. + # + # These are implemented as aliases into the Snit runtime library. + + interp alias {} %TYPE%::installhull {} ::snit::RT.installhull %TYPE% + interp alias {} %TYPE%::install {} ::snit::RT.install %TYPE% + interp alias {} %TYPE%::typevariable {} ::variable + interp alias {} %TYPE%::variable {} ::snit::RT.variable + interp alias {} %TYPE%::mytypevar {} ::snit::RT.mytypevar %TYPE% + interp alias {} %TYPE%::typevarname {} ::snit::RT.mytypevar %TYPE% + interp alias {} %TYPE%::myvar {} ::snit::RT.myvar + interp alias {} %TYPE%::varname {} ::snit::RT.myvar + interp alias {} %TYPE%::codename {} ::snit::RT.codename %TYPE% + interp alias {} %TYPE%::myproc {} ::snit::RT.myproc %TYPE% + interp alias {} %TYPE%::mymethod {} ::snit::RT.mymethod + interp alias {} %TYPE%::mytypemethod {} ::snit::RT.mytypemethod %TYPE% + interp alias {} %TYPE%::from {} ::snit::RT.from %TYPE% + + #------------------------------------------------------------------- + # Snit's internal variables + + namespace eval %TYPE% { + # Array: General Snit Info + # + # ns: The type's namespace + # hasinstances: T or F, from pragma -hasinstances. + # simpledispatch: T or F, from pragma -hasinstances. + # canreplace: T or F, from pragma -canreplace. + # counter: Count of instances created so far. + # widgetclass: Set by widgetclass statement. + # hulltype: Hull type (frame or toplevel) for widgets only. + # exceptmethods: Methods explicitly not delegated to * + # excepttypemethods: Methods explicitly not delegated to * + # tvardecs: Type variable declarations--for dynamic methods + # ivardecs: Instance variable declarations--for dyn. methods + typevariable Snit_info + set Snit_info(ns) %TYPE%:: + set Snit_info(hasinstances) 1 + set Snit_info(simpledispatch) 0 + set Snit_info(canreplace) 0 + set Snit_info(counter) 0 + set Snit_info(widgetclass) {} + set Snit_info(hulltype) frame + set Snit_info(exceptmethods) {} + set Snit_info(excepttypemethods) {} + set Snit_info(tvardecs) {%TVARDECS%} + set Snit_info(ivardecs) {%IVARDECS%} + + # Array: Public methods of this type. + # The index is the method name, or "*". + # The value is [list $pattern $componentName], where + # $componentName is "" for normal methods. + typevariable Snit_typemethodInfo + array unset Snit_typemethodInfo + + # Array: Public methods of instances of this type. + # The index is the method name, or "*". + # The value is [list $pattern $componentName], where + # $componentName is "" for normal methods. + typevariable Snit_methodInfo + array unset Snit_methodInfo + + # Array: option information. See dictionary.txt. + typevariable Snit_optionInfo + array unset Snit_optionInfo + set Snit_optionInfo(local) {} + set Snit_optionInfo(delegated) {} + set Snit_optionInfo(starcomp) {} + set Snit_optionInfo(except) {} + } + + #---------------------------------------------------------------- + # Compiled Procs + # + # These commands are created or replaced during compilation: + + + # Snit_instanceVars selfns + # + # Initializes the instance variables, if any. Called during + # instance creation. + + proc %TYPE%::Snit_instanceVars {selfns} { + %INSTANCEVARS% + } + + # Type Constructor + proc %TYPE%::Snit_typeconstructor {type} { + %TVARDECS% + %TCONSTBODY% + } + + #---------------------------------------------------------------- + # Default Procs + # + # These commands might be replaced during compilation: + + # Snit_destructor type selfns win self + # + # Default destructor for the type. By default, it does + # nothing. It's replaced by any user destructor. + # For types, it's called by method destroy; for widgettypes, + # it's called by a destroy event handler. + + proc %TYPE%::Snit_destructor {type selfns win self} { } + + #---------------------------------------------------------- + # Compiled Definitions + + %COMPILEDDEFS% + + #---------------------------------------------------------- + # Finally, call the Type Constructor + + %TYPE%::Snit_typeconstructor %TYPE% +} + +#----------------------------------------------------------------------- +# Type procs +# +# These procs expect the fully-qualified type name to be +# substituted in for %TYPE%. + +# This is the nominal type proc. It supports typemethods and +# delegated typemethods. +set ::snit::nominalTypeProc { + # Type dispatcher function. Note: This function lives + # in the parent of the %TYPE% namespace! All accesses to + # %TYPE% variables and methods must be qualified! + proc %TYPE% {{method ""} args} { + # First, if there's no method, and no args, and there's a create + # method, and this isn't a widget, then method is "create" and + # "args" is %AUTO%. + if {"" == $method && [llength $args] == 0} { + ::variable %TYPE%::Snit_info + + if {$Snit_info(hasinstances) && !$Snit_info(isWidget)} { + set method create + lappend args %AUTO% + } else { + error "wrong \# args: should be \"%TYPE% method args\"" + } + } + + # Next, retrieve the command. + variable %TYPE%::Snit_typemethodCache + while 1 { + if {[catch {set Snit_typemethodCache($method)} commandRec]} { + set commandRec [::snit::RT.CacheTypemethodCommand %TYPE% $method] + + if {[llength $commandRec] == 0} { + return -code error "\"%TYPE% $method\" is not defined" + } + } + + # If we've got a real command, break. + if {[lindex $commandRec 0] == 0} { + break + } + + # Otherwise, we need to look up again...if we can. + if {[llength $args] == 0} { + return -code error \ + "wrong number args: should be \"%TYPE% $method method args\"" + } + + lappend method [lindex $args 0] + set args [lrange $args 1 end] + } + + set command [lindex $commandRec 1] + + # Pass along the return code unchanged. + set retval [catch {uplevel 1 $command $args} result] + + if {$retval} { + if {$retval == 1} { + global errorInfo + global errorCode + return -code error -errorinfo $errorInfo \ + -errorcode $errorCode $result + } else { + return -code $retval $result + } + } + + return $result + } +} + +# This is the simplified type proc for when there are no typemethods +# except create. In this case, it doesn't take a method argument; +# the method is always "create". +set ::snit::simpleTypeProc { + # Type dispatcher function. Note: This function lives + # in the parent of the %TYPE% namespace! All accesses to + # %TYPE% variables and methods must be qualified! + proc %TYPE% {args} { + ::variable %TYPE%::Snit_info + + # FIRST, if the are no args, the single arg is %AUTO% + if {[llength $args] == 0} { + if {$Snit_info(isWidget)} { + error "wrong \# args: should be \"%TYPE% name args\"" + } + + lappend args %AUTO% + } + + # NEXT, we're going to call the create method. + # Pass along the return code unchanged. + if {$Snit_info(isWidget)} { + set command [list ::snit::RT.widget.typemethod.create %TYPE%] + } else { + set command [list ::snit::RT.type.typemethod.create %TYPE%] + } + + set retval [catch {uplevel 1 $command $args} result] + + if {$retval} { + if {$retval == 1} { + global errorInfo + global errorCode + return -code error -errorinfo $errorInfo \ + -errorcode $errorCode $result + } else { + return -code $retval $result + } + } + + return $result + } +} + +#----------------------------------------------------------------------- +# Instance procs +# +# The following must be substituted into these proc bodies: +# +# %SELFNS% The instance namespace +# %WIN% The original instance name +# %TYPE% The fully-qualified type name +# + +# Nominal instance proc body: supports method caching and delegation. +# +# proc $instanceName {method args} .... +set ::snit::nominalInstanceProc { + set self [set %SELFNS%::Snit_instance] + + while {1} { + if {[catch {set %SELFNS%::Snit_methodCache($method)} commandRec]} { + set commandRec [snit::RT.CacheMethodCommand %TYPE% %SELFNS% %WIN% $self $method] + + if {[llength $commandRec] == 0} { + return -code error \ + "\"$self $method\" is not defined" + } + } + + # If we've got a real command, break. + if {[lindex $commandRec 0] == 0} { + break + } + + # Otherwise, we need to look up again...if we can. + if {[llength $args] == 0} { + return -code error \ + "wrong number args: should be \"$self $method method args\"" + } + + lappend method [lindex $args 0] + set args [lrange $args 1 end] + } + + set command [lindex $commandRec 1] + + # Pass along the return code unchanged. + set retval [catch {uplevel 1 $command $args} result] + + if {$retval} { + if {$retval == 1} { + global errorInfo + global errorCode + return -code error -errorinfo $errorInfo \ + -errorcode $errorCode $result + } else { + return -code $retval $result + } + } + + return $result +} + +# Simplified method proc body: No delegation allowed; no support for +# upvar or exotic return codes or hierarchical methods. Designed for +# max speed for simple types. +# +# proc $instanceName {method args} .... + +set ::snit::simpleInstanceProc { + set self [set %SELFNS%::Snit_instance] + + if {[lsearch -exact ${%TYPE%::Snit_methods} $method] == -1} { + set optlist [join ${%TYPE%::Snit_methods} ", "] + set optlist [linsert $optlist "end-1" "or"] + error "bad option \"$method\": must be $optlist" + } + + eval [linsert $args 0 \ + %TYPE%::Snit_method$method %TYPE% %SELFNS% %WIN% $self] +} + + +#======================================================================= +# Snit Type Definition +# +# These are the procs used to define Snit types, widgets, and +# widgetadaptors. + + +#----------------------------------------------------------------------- +# Snit Compilation Variables +# +# The following variables are used while Snit is compiling a type, +# and are disposed afterwards. + +namespace eval ::snit:: { + # The compiler variable contains the name of the slave interpreter + # used to compile type definitions. + variable compiler "" + + # The compile array accumulates information about the type or + # widgettype being compiled. It is cleared before and after each + # compilation. It has these indices: + # + # type: The name of the type being compiled, for use + # in compilation procs. + # defs: Compiled definitions, both standard and client. + # which: type, widget, widgetadaptor + # instancevars: Instance variable definitions and initializations. + # ivprocdec: Instance variable proc declarations. + # tvprocdec: Type variable proc declarations. + # typeconstructor: Type constructor body. + # widgetclass: The widgetclass, for snit::widgets, only + # hasoptions: False, initially; set to true when first + # option is defined. + # localoptions: Names of local options. + # delegatedoptions: Names of delegated options. + # localmethods: Names of locally defined methods. + # delegatesmethods: no if no delegated methods, yes otherwise. + # hashierarchic : no if no hierarchic methods, yes otherwise. + # components: Names of defined components. + # typecomponents: Names of defined typecomponents. + # typevars: Typevariable definitions and initializations. + # varnames: Names of instance variables + # typevarnames Names of type variables + # hasconstructor False, initially; true when constructor is + # defined. + # resource-$opt The option's resource name + # class-$opt The option's class + # -default-$opt The option's default value + # -validatemethod-$opt The option's validate method + # -configuremethod-$opt The option's configure method + # -cgetmethod-$opt The option's cget method. + # -hastypeinfo The -hastypeinfo pragma + # -hastypedestroy The -hastypedestroy pragma + # -hastypemethods The -hastypemethods pragma + # -hasinfo The -hasinfo pragma + # -hasinstances The -hasinstances pragma + # -simpledispatch The -simpledispatch pragma + # -canreplace The -canreplace pragma + variable compile + + # This variable accumulates method dispatch information; it has + # the same structure as the %TYPE%::Snit_methodInfo array, and is + # used to initialize it. + variable methodInfo + + # This variable accumulates typemethod dispatch information; it has + # the same structure as the %TYPE%::Snit_typemethodInfo array, and is + # used to initialize it. + variable typemethodInfo + + # The following variable lists the reserved type definition statement + # names, e.g., the names you can't use as macros. It's built at + # compiler definition time using "info commands". + variable reservedwords {} +} + +#----------------------------------------------------------------------- +# type compilation commands +# +# The type and widgettype commands use a slave interpreter to compile +# the type definition. These are the procs +# that are aliased into it. + +# Initialize the compiler +proc ::snit::Comp.Init {} { + variable compiler + variable reservedwords + + if {"" == $compiler} { + # Create the compiler's interpreter + set compiler [interp create] + + # Initialize the interpreter + $compiler eval { + catch {close stdout} + catch {close stderr} + catch {close stdin} + + # Load package information + # TBD: see if this can be moved outside. + # @mdgen NODEP: ::snit::__does_not_exist__ + catch {package require ::snit::__does_not_exist__} + + # Protect some Tcl commands our type definitions + # will shadow. + rename proc _proc + rename variable _variable + } + + # Define compilation aliases. + $compiler alias pragma ::snit::Comp.statement.pragma + $compiler alias widgetclass ::snit::Comp.statement.widgetclass + $compiler alias hulltype ::snit::Comp.statement.hulltype + $compiler alias constructor ::snit::Comp.statement.constructor + $compiler alias destructor ::snit::Comp.statement.destructor + $compiler alias option ::snit::Comp.statement.option + $compiler alias oncget ::snit::Comp.statement.oncget + $compiler alias onconfigure ::snit::Comp.statement.onconfigure + $compiler alias method ::snit::Comp.statement.method + $compiler alias typemethod ::snit::Comp.statement.typemethod + $compiler alias typeconstructor ::snit::Comp.statement.typeconstructor + $compiler alias proc ::snit::Comp.statement.proc + $compiler alias typevariable ::snit::Comp.statement.typevariable + $compiler alias variable ::snit::Comp.statement.variable + $compiler alias typecomponent ::snit::Comp.statement.typecomponent + $compiler alias component ::snit::Comp.statement.component + $compiler alias delegate ::snit::Comp.statement.delegate + $compiler alias expose ::snit::Comp.statement.expose + + # Get the list of reserved words + set reservedwords [$compiler eval {info commands}] + } +} + +# Compile a type definition, and return the results as a list of two +# items: the fully-qualified type name, and a script that will define +# the type when executed. +# +# which type, widget, or widgetadaptor +# type the type name +# body the type definition +proc ::snit::Comp.Compile {which type body} { + variable typeTemplate + variable nominalTypeProc + variable simpleTypeProc + variable compile + variable compiler + variable methodInfo + variable typemethodInfo + + # FIRST, qualify the name. + if {![string match "::*" $type]} { + # Get caller's namespace; + # append :: if not global namespace. + set ns [uplevel 2 [list namespace current]] + if {"::" != $ns} { + append ns "::" + } + + set type "$ns$type" + } + + # NEXT, create and initialize the compiler, if needed. + Comp.Init + + # NEXT, initialize the class data + array unset methodInfo + array unset typemethodInfo + + array unset compile + set compile(type) $type + set compile(defs) {} + set compile(which) $which + set compile(hasoptions) no + set compile(localoptions) {} + set compile(instancevars) {} + set compile(typevars) {} + set compile(delegatedoptions) {} + set compile(ivprocdec) {} + set compile(tvprocdec) {} + set compile(typeconstructor) {} + set compile(widgetclass) {} + set compile(hulltype) {} + set compile(localmethods) {} + set compile(delegatesmethods) no + set compile(hashierarchic) no + set compile(components) {} + set compile(typecomponents) {} + set compile(varnames) {} + set compile(typevarnames) {} + set compile(hasconstructor) no + set compile(-hastypedestroy) yes + set compile(-hastypeinfo) yes + set compile(-hastypemethods) yes + set compile(-hasinfo) yes + set compile(-hasinstances) yes + set compile(-simpledispatch) no + set compile(-canreplace) no + + set isWidget [string match widget* $which] + set isWidgetAdaptor [string match widgetadaptor $which] + + # NEXT, Evaluate the type's definition in the class interpreter. + $compiler eval $body + + # NEXT, Add the standard definitions + append compile(defs) \ + "\nset %TYPE%::Snit_info(isWidget) $isWidget\n" + + append compile(defs) \ + "\nset %TYPE%::Snit_info(isWidgetAdaptor) $isWidgetAdaptor\n" + + # Indicate whether the type can create instances that replace + # existing commands. + append compile(defs) "\nset %TYPE%::Snit_info(canreplace) $compile(-canreplace)\n" + + + # Check pragmas for conflict. + + if {!$compile(-hastypemethods) && !$compile(-hasinstances)} { + error "$which $type has neither typemethods nor instances" + } + + if {$compile(-simpledispatch) && $compile(delegatesmethods)} { + error "$which $type requests -simpledispatch but delegates methods." + } + + if {$compile(-simpledispatch) && $compile(hashierarchic)} { + error "$which $type requests -simpledispatch but defines hierarchical methods." + } + + # If there are typemethods, define the standard typemethods and + # the nominal type proc. Otherwise define the simple type proc. + if {$compile(-hastypemethods)} { + # Add the info typemethod unless the pragma forbids it. + if {$compile(-hastypeinfo)} { + Comp.statement.delegate typemethod info \ + using {::snit::RT.typemethod.info %t} + } + + # Add the destroy typemethod unless the pragma forbids it. + if {$compile(-hastypedestroy)} { + Comp.statement.delegate typemethod destroy \ + using {::snit::RT.typemethod.destroy %t} + } + + # Add the nominal type proc. + append compile(defs) $nominalTypeProc + } else { + # Add the simple type proc. + append compile(defs) $simpleTypeProc + } + + # Add standard methods/typemethods that only make sense if the + # type has instances. + if {$compile(-hasinstances)} { + # If we're using simple dispatch, remember that. + if {$compile(-simpledispatch)} { + append compile(defs) "\nset %TYPE%::Snit_info(simpledispatch) 1\n" + } + + # Add the info method unless the pragma forbids it. + if {$compile(-hasinfo)} { + if {!$compile(-simpledispatch)} { + Comp.statement.delegate method info \ + using {::snit::RT.method.info %t %n %w %s} + } else { + Comp.statement.method info {args} { + eval [linsert $args 0 \ + ::snit::RT.method.info $type $selfns $win $self] + } + } + } + + # Add the option handling stuff if there are any options. + if {$compile(hasoptions)} { + Comp.statement.variable options + + if {!$compile(-simpledispatch)} { + Comp.statement.delegate method cget \ + using {::snit::RT.method.cget %t %n %w %s} + Comp.statement.delegate method configurelist \ + using {::snit::RT.method.configurelist %t %n %w %s} + Comp.statement.delegate method configure \ + using {::snit::RT.method.configure %t %n %w %s} + } else { + Comp.statement.method cget {args} { + eval [linsert $args 0 \ + ::snit::RT.method.cget $type $selfns $win $self] + } + Comp.statement.method configurelist {args} { + eval [linsert $args 0 \ + ::snit::RT.method.configurelist $type $selfns $win $self] + } + Comp.statement.method configure {args} { + eval [linsert $args 0 \ + ::snit::RT.method.configure $type $selfns $win $self] + } + } + } + + # Add a default constructor, if they haven't already defined one. + # If there are options, it will configure args; otherwise it + # will do nothing. + if {!$compile(hasconstructor)} { + if {$compile(hasoptions)} { + Comp.statement.constructor {args} { + $self configurelist $args + } + } else { + Comp.statement.constructor {} {} + } + } + + if {!$isWidget} { + if {!$compile(-simpledispatch)} { + Comp.statement.delegate method destroy \ + using {::snit::RT.method.destroy %t %n %w %s} + } else { + Comp.statement.method destroy {args} { + eval [linsert $args 0 \ + ::snit::RT.method.destroy $type $selfns $win $self] + } + } + + Comp.statement.delegate typemethod create \ + using {::snit::RT.type.typemethod.create %t} + } else { + Comp.statement.delegate typemethod create \ + using {::snit::RT.widget.typemethod.create %t} + } + + # Save the list of method names, for -simpledispatch; otherwise, + # save the method info. + if {$compile(-simpledispatch)} { + append compile(defs) \ + "\nset %TYPE%::Snit_methods [list $compile(localmethods)]\n" + } else { + append compile(defs) \ + "\narray set %TYPE%::Snit_methodInfo [list [array get methodInfo]]\n" + } + + } else { + append compile(defs) "\nset %TYPE%::Snit_info(hasinstances) 0\n" + } + + # NEXT, compiling the type definition built up a set of information + # about the type's locally defined options; add this information to + # the compiled definition. + Comp.SaveOptionInfo + + # NEXT, compiling the type definition built up a set of information + # about the typemethods; save the typemethod info. + append compile(defs) \ + "\narray set %TYPE%::Snit_typemethodInfo [list [array get typemethodInfo]]\n" + + # NEXT, if this is a widget define the hull component if it isn't + # already defined. + if {$isWidget} { + Comp.DefineComponent hull + } + + # NEXT, substitute the compiled definition into the type template + # to get the type definition script. + set defscript [Expand $typeTemplate \ + %COMPILEDDEFS% $compile(defs)] + + # NEXT, substitute the defined macros into the type definition script. + # This is done as a separate step so that the compile(defs) can + # contain the macros defined below. + + set defscript [Expand $defscript \ + %TYPE% $type \ + %IVARDECS% $compile(ivprocdec) \ + %TVARDECS% $compile(tvprocdec) \ + %TCONSTBODY% $compile(typeconstructor) \ + %INSTANCEVARS% $compile(instancevars) \ + %TYPEVARS% $compile(typevars) \ + ] + + array unset compile + + return [list $type $defscript] +} + +# Information about locally-defined options is accumulated during +# compilation, but not added to the compiled definition--the option +# statement can appear multiple times, so it's easier this way. +# This proc fills in Snit_optionInfo with the accumulated information. +# +# It also computes the option's resource and class names if needed. +# +# Note that the information for delegated options was put in +# Snit_optionInfo during compilation. + +proc ::snit::Comp.SaveOptionInfo {} { + variable compile + + foreach option $compile(localoptions) { + if {"" == $compile(resource-$option)} { + set compile(resource-$option) [string range $option 1 end] + } + + if {"" == $compile(class-$option)} { + set compile(class-$option) [Capitalize $compile(resource-$option)] + } + + # NOTE: Don't verify that the validate, configure, and cget + # values name real methods; the methods might be defined outside + # the typedefinition using snit::method. + + Mappend compile(defs) { + # Option %OPTION% + lappend %TYPE%::Snit_optionInfo(local) %OPTION% + + set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 1 + set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RESOURCE% + set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS% + set %TYPE%::Snit_optionInfo(default-%OPTION%) %DEFAULT% + set %TYPE%::Snit_optionInfo(validate-%OPTION%) %VALIDATE% + set %TYPE%::Snit_optionInfo(configure-%OPTION%) %CONFIGURE% + set %TYPE%::Snit_optionInfo(cget-%OPTION%) %CGET% + set %TYPE%::Snit_optionInfo(readonly-%OPTION%) %READONLY% + set %TYPE%::Snit_optionInfo(typespec-%OPTION%) %TYPESPEC% + } %OPTION% $option \ + %RESOURCE% $compile(resource-$option) \ + %CLASS% $compile(class-$option) \ + %DEFAULT% [list $compile(-default-$option)] \ + %VALIDATE% [list $compile(-validatemethod-$option)] \ + %CONFIGURE% [list $compile(-configuremethod-$option)] \ + %CGET% [list $compile(-cgetmethod-$option)] \ + %READONLY% $compile(-readonly-$option) \ + %TYPESPEC% [list $compile(-type-$option)] + } +} + + +# Evaluates a compiled type definition, thus making the type available. +proc ::snit::Comp.Define {compResult} { + # The compilation result is a list containing the fully qualified + # type name and a script to evaluate to define the type. + set type [lindex $compResult 0] + set defscript [lindex $compResult 1] + + # Execute the type definition script. + # Consider using namespace eval %TYPE%. See if it's faster. + if {[catch {eval $defscript} result]} { + namespace delete $type + catch {rename $type ""} + error $result + } + + return $type +} + +# Sets pragma options which control how the type is defined. +proc ::snit::Comp.statement.pragma {args} { + variable compile + + set errRoot "Error in \"pragma...\"" + + foreach {opt val} $args { + switch -exact -- $opt { + -hastypeinfo - + -hastypedestroy - + -hastypemethods - + -hasinstances - + -simpledispatch - + -hasinfo - + -canreplace { + if {![string is boolean -strict $val]} { + error "$errRoot, \"$opt\" requires a boolean value" + } + set compile($opt) $val + } + default { + error "$errRoot, unknown pragma" + } + } + } +} + +# Defines a widget's option class name. +# This statement is only available for snit::widgets, +# not for snit::types or snit::widgetadaptors. +proc ::snit::Comp.statement.widgetclass {name} { + variable compile + + # First, widgetclass can only be set for true widgets + if {"widget" != $compile(which)} { + error "widgetclass cannot be set for snit::$compile(which)s" + } + + # Next, validate the option name. We'll require that it begin + # with an uppercase letter. + set initial [string index $name 0] + if {![string is upper $initial]} { + error "widgetclass \"$name\" does not begin with an uppercase letter" + } + + if {"" != $compile(widgetclass)} { + error "too many widgetclass statements" + } + + # Next, save it. + Mappend compile(defs) { + set %TYPE%::Snit_info(widgetclass) %WIDGETCLASS% + } %WIDGETCLASS% [list $name] + + set compile(widgetclass) $name +} + +# Defines a widget's hull type. +# This statement is only available for snit::widgets, +# not for snit::types or snit::widgetadaptors. +proc ::snit::Comp.statement.hulltype {name} { + variable compile + variable hulltypes + + # First, hulltype can only be set for true widgets + if {"widget" != $compile(which)} { + error "hulltype cannot be set for snit::$compile(which)s" + } + + # Next, it must be one of the valid hulltypes (frame, toplevel, ...) + if {[lsearch -exact $hulltypes [string trimleft $name :]] == -1} { + error "invalid hulltype \"$name\", should be one of\ + [join $hulltypes {, }]" + } + + if {"" != $compile(hulltype)} { + error "too many hulltype statements" + } + + # Next, save it. + Mappend compile(defs) { + set %TYPE%::Snit_info(hulltype) %HULLTYPE% + } %HULLTYPE% $name + + set compile(hulltype) $name +} + +# Defines a constructor. +proc ::snit::Comp.statement.constructor {arglist body} { + variable compile + + CheckArgs "constructor" $arglist + + # Next, add a magic reference to self. + set arglist [concat type selfns win self $arglist] + + # Next, add variable declarations to body: + set body "%TVARDECS%%IVARDECS%\n$body" + + set compile(hasconstructor) yes + append compile(defs) "proc %TYPE%::Snit_constructor [list $arglist] [list $body]\n" +} + +# Defines a destructor. +proc ::snit::Comp.statement.destructor {body} { + variable compile + + # Next, add variable declarations to body: + set body "%TVARDECS%%IVARDECS%\n$body" + + append compile(defs) "proc %TYPE%::Snit_destructor {type selfns win self} [list $body]\n\n" +} + +# Defines a type option. The option value can be a triple, specifying +# the option's -name, resource name, and class name. +proc ::snit::Comp.statement.option {optionDef args} { + variable compile + + # First, get the three option names. + set option [lindex $optionDef 0] + set resourceName [lindex $optionDef 1] + set className [lindex $optionDef 2] + + set errRoot "Error in \"option [list $optionDef]...\"" + + # Next, validate the option name. + if {![Comp.OptionNameIsValid $option]} { + error "$errRoot, badly named option \"$option\"" + } + + if {[Contains $option $compile(delegatedoptions)]} { + error "$errRoot, cannot define \"$option\" locally, it has been delegated" + } + + if {![Contains $option $compile(localoptions)]} { + # Remember that we've seen this one. + set compile(hasoptions) yes + lappend compile(localoptions) $option + + # Initialize compilation info for this option. + set compile(resource-$option) "" + set compile(class-$option) "" + set compile(-default-$option) "" + set compile(-validatemethod-$option) "" + set compile(-configuremethod-$option) "" + set compile(-cgetmethod-$option) "" + set compile(-readonly-$option) 0 + set compile(-type-$option) "" + } + + # NEXT, see if we have a resource name. If so, make sure it + # isn't being redefined differently. + if {"" != $resourceName} { + if {"" == $compile(resource-$option)} { + # If it's undefined, just save the value. + set compile(resource-$option) $resourceName + } elseif {![string equal $resourceName $compile(resource-$option)]} { + # It's been redefined differently. + error "$errRoot, resource name redefined from \"$compile(resource-$option)\" to \"$resourceName\"" + } + } + + # NEXT, see if we have a class name. If so, make sure it + # isn't being redefined differently. + if {"" != $className} { + if {"" == $compile(class-$option)} { + # If it's undefined, just save the value. + set compile(class-$option) $className + } elseif {![string equal $className $compile(class-$option)]} { + # It's been redefined differently. + error "$errRoot, class name redefined from \"$compile(class-$option)\" to \"$className\"" + } + } + + # NEXT, handle the args; it's not an error to redefine these. + if {[llength $args] == 1} { + set compile(-default-$option) [lindex $args 0] + } else { + foreach {optopt val} $args { + switch -exact -- $optopt { + -default - + -validatemethod - + -configuremethod - + -cgetmethod { + set compile($optopt-$option) $val + } + -type { + set compile($optopt-$option) $val + + if {[llength $val] == 1} { + # The type spec *is* the validation object + append compile(defs) \ + "\nset %TYPE%::Snit_optionInfo(typeobj-$option) [list $val]\n" + } else { + # Compilation the creation of the validation object + set cmd [linsert $val 1 %TYPE%::Snit_TypeObj_%AUTO%] + append compile(defs) \ + "\nset %TYPE%::Snit_optionInfo(typeobj-$option) \[$cmd\]\n" + } + } + -readonly { + if {![string is boolean -strict $val]} { + error "$errRoot, -readonly requires a boolean, got \"$val\"" + } + set compile($optopt-$option) $val + } + default { + error "$errRoot, unknown option definition option \"$optopt\"" + } + } + } + } +} + +# 1 if the option name is valid, 0 otherwise. +proc ::snit::Comp.OptionNameIsValid {option} { + if {![string match {-*} $option] || [string match {*[A-Z ]*} $option]} { + return 0 + } + + return 1 +} + +# Defines an option's cget handler +proc ::snit::Comp.statement.oncget {option body} { + variable compile + + set errRoot "Error in \"oncget $option...\"" + + if {[lsearch -exact $compile(delegatedoptions) $option] != -1} { + return -code error "$errRoot, option \"$option\" is delegated" + } + + if {[lsearch -exact $compile(localoptions) $option] == -1} { + return -code error "$errRoot, option \"$option\" unknown" + } + + Comp.statement.method _cget$option {_option} $body + Comp.statement.option $option -cgetmethod _cget$option +} + +# Defines an option's configure handler. +proc ::snit::Comp.statement.onconfigure {option arglist body} { + variable compile + + if {[lsearch -exact $compile(delegatedoptions) $option] != -1} { + return -code error "onconfigure $option: option \"$option\" is delegated" + } + + if {[lsearch -exact $compile(localoptions) $option] == -1} { + return -code error "onconfigure $option: option \"$option\" unknown" + } + + if {[llength $arglist] != 1} { + error \ + "onconfigure $option handler should have one argument, got \"$arglist\"" + } + + CheckArgs "onconfigure $option" $arglist + + # Next, add a magic reference to the option name + set arglist [concat _option $arglist] + + Comp.statement.method _configure$option $arglist $body + Comp.statement.option $option -configuremethod _configure$option +} + +# Defines an instance method. +proc ::snit::Comp.statement.method {method arglist body} { + variable compile + variable methodInfo + + # FIRST, check the method name against previously defined + # methods. + Comp.CheckMethodName $method 0 ::snit::methodInfo \ + "Error in \"method [list $method]...\"" + + if {[llength $method] > 1} { + set compile(hashierarchic) yes + } + + # Remeber this method + lappend compile(localmethods) $method + + CheckArgs "method [list $method]" $arglist + + # Next, add magic references to type and self. + set arglist [concat type selfns win self $arglist] + + # Next, add variable declarations to body: + set body "%TVARDECS%%IVARDECS%\n# END snit method prolog\n$body" + + # Next, save the definition script. + if {[llength $method] == 1} { + set methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""} + Mappend compile(defs) { + proc %TYPE%::Snit_method%METHOD% %ARGLIST% %BODY% + } %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body] + } else { + set methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""} + + Mappend compile(defs) { + proc %TYPE%::Snit_hmethod%JMETHOD% %ARGLIST% %BODY% + } %JMETHOD% [join $method _] %ARGLIST% [list $arglist] \ + %BODY% [list $body] + } +} + +# Check for name collisions; save prefix information. +# +# method The name of the method or typemethod. +# delFlag 1 if delegated, 0 otherwise. +# infoVar The fully qualified name of the array containing +# information about the defined methods. +# errRoot The root string for any error messages. + +proc ::snit::Comp.CheckMethodName {method delFlag infoVar errRoot} { + upvar $infoVar methodInfo + + # FIRST, make sure the method name is a valid Tcl list. + if {[catch {lindex $method 0}]} { + error "$errRoot, the name \"$method\" must have list syntax." + } + + # NEXT, check whether we can define it. + if {![catch {set methodInfo($method)} data]} { + # We can't redefine methods with submethods. + if {[lindex $data 0] == 1} { + error "$errRoot, \"$method\" has submethods." + } + + # You can't delegate a method that's defined locally, + # and you can't define a method locally if it's been delegated. + if {$delFlag && "" == [lindex $data 2]} { + error "$errRoot, \"$method\" has been defined locally." + } elseif {!$delFlag && "" != [lindex $data 2]} { + error "$errRoot, \"$method\" has been delegated" + } + } + + # Handle hierarchical case. + if {[llength $method] > 1} { + set prefix {} + set tokens $method + while {[llength $tokens] > 1} { + lappend prefix [lindex $tokens 0] + set tokens [lrange $tokens 1 end] + + if {![catch {set methodInfo($prefix)} result]} { + # Prefix is known. If it's not a prefix, throw an + # error. + if {[lindex $result 0] == 0} { + error "$errRoot, \"$prefix\" has no submethods." + } + } + + set methodInfo($prefix) [list 1] + } + } +} + +# Defines a typemethod method. +proc ::snit::Comp.statement.typemethod {method arglist body} { + variable compile + variable typemethodInfo + + # FIRST, check the typemethod name against previously defined + # typemethods. + Comp.CheckMethodName $method 0 ::snit::typemethodInfo \ + "Error in \"typemethod [list $method]...\"" + + CheckArgs "typemethod $method" $arglist + + # First, add magic reference to type. + set arglist [concat type $arglist] + + # Next, add typevariable declarations to body: + set body "%TVARDECS%\n# END snit method prolog\n$body" + + # Next, save the definition script + if {[llength $method] == 1} { + set typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""} + + Mappend compile(defs) { + proc %TYPE%::Snit_typemethod%METHOD% %ARGLIST% %BODY% + } %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body] + } else { + set typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""} + + Mappend compile(defs) { + proc %TYPE%::Snit_htypemethod%JMETHOD% %ARGLIST% %BODY% + } %JMETHOD% [join $method _] \ + %ARGLIST% [list $arglist] %BODY% [list $body] + } +} + + +# Defines a type constructor. +proc ::snit::Comp.statement.typeconstructor {body} { + variable compile + + if {"" != $compile(typeconstructor)} { + error "too many typeconstructors" + } + + set compile(typeconstructor) $body +} + +# Defines a static proc in the type's namespace. +proc ::snit::Comp.statement.proc {proc arglist body} { + variable compile + + # If "ns" is defined, the proc can see instance variables. + if {[lsearch -exact $arglist selfns] != -1} { + # Next, add instance variable declarations to body: + set body "%IVARDECS%\n$body" + } + + # The proc can always see typevariables. + set body "%TVARDECS%\n$body" + + append compile(defs) " + + # Proc $proc + proc [list %TYPE%::$proc $arglist $body] + " +} + +# Defines a static variable in the type's namespace. +proc ::snit::Comp.statement.typevariable {name args} { + variable compile + + set errRoot "Error in \"typevariable $name...\"" + + set len [llength $args] + + if {$len > 2 || + ($len == 2 && "-array" != [lindex $args 0])} { + error "$errRoot, too many initializers" + } + + if {[lsearch -exact $compile(varnames) $name] != -1} { + error "$errRoot, \"$name\" is already an instance variable" + } + + lappend compile(typevarnames) $name + + if {$len == 1} { + append compile(typevars) \ + "\n\t [list ::variable $name [lindex $args 0]]" + } elseif {$len == 2} { + append compile(typevars) \ + "\n\t [list ::variable $name]" + append compile(typevars) \ + "\n\t [list array set $name [lindex $args 1]]" + } else { + append compile(typevars) \ + "\n\t [list ::variable $name]" + } + + append compile(tvprocdec) "\n\t typevariable ${name}" +} + +# Defines an instance variable; the definition will go in the +# type's create typemethod. +proc ::snit::Comp.statement.variable {name args} { + variable compile + + set errRoot "Error in \"variable $name...\"" + + set len [llength $args] + + if {$len > 2 || + ($len == 2 && "-array" != [lindex $args 0])} { + error "$errRoot, too many initializers" + } + + if {[lsearch -exact $compile(typevarnames) $name] != -1} { + error "$errRoot, \"$name\" is already a typevariable" + } + + lappend compile(varnames) $name + + if {$len == 1} { + append compile(instancevars) \ + "\nset \${selfns}::$name [list [lindex $args 0]]\n" + } elseif {$len == 2} { + append compile(instancevars) \ + "\narray set \${selfns}::$name [list [lindex $args 1]]\n" + } + + append compile(ivprocdec) "\n\t " + Mappend compile(ivprocdec) {::variable ${selfns}::%N} %N $name +} + +# Defines a typecomponent, and handles component options. +# +# component The logical name of the delegate +# args options. + +proc ::snit::Comp.statement.typecomponent {component args} { + variable compile + + set errRoot "Error in \"typecomponent $component...\"" + + # FIRST, define the component + Comp.DefineTypecomponent $component $errRoot + + # NEXT, handle the options. + set publicMethod "" + set inheritFlag 0 + + foreach {opt val} $args { + switch -exact -- $opt { + -public { + set publicMethod $val + } + -inherit { + set inheritFlag $val + if {![string is boolean $inheritFlag]} { + error "typecomponent $component -inherit: expected boolean value, got \"$val\"" + } + } + default { + error "typecomponent $component: Invalid option \"$opt\"" + } + } + } + + # NEXT, if -public specified, define the method. + if {"" != $publicMethod} { + Comp.statement.delegate typemethod [list $publicMethod *] to $component + } + + # NEXT, if "-inherit 1" is specified, delegate typemethod * to + # this component. + if {$inheritFlag} { + Comp.statement.delegate typemethod "*" to $component + } + +} + + +# Defines a name to be a typecomponent +# +# The name becomes a typevariable; in addition, it gets a +# write trace so that when it is set, all of the component mechanisms +# get updated. +# +# component The component name + +proc ::snit::Comp.DefineTypecomponent {component {errRoot "Error"}} { + variable compile + + if {[lsearch -exact $compile(varnames) $component] != -1} { + error "$errRoot, \"$component\" is already an instance variable" + } + + if {[lsearch -exact $compile(typecomponents) $component] == -1} { + # Remember we've done this. + lappend compile(typecomponents) $component + + # Make it a type variable with no initial value + Comp.statement.typevariable $component "" + + # Add a write trace to do the component thing. + Mappend compile(typevars) { + trace add variable %COMP% write \ + [list ::snit::RT.TypecomponentTrace [list %TYPE%] %COMP%] + } %TYPE% $compile(type) %COMP% $component + } +} + +# Defines a component, and handles component options. +# +# component The logical name of the delegate +# args options. +# +# TBD: Ideally, it should be possible to call this statement multiple +# times, possibly changing the option values. To do that, I'd need +# to cache the option values and not act on them until *after* I'd +# read the entire type definition. + +proc ::snit::Comp.statement.component {component args} { + variable compile + + set errRoot "Error in \"component $component...\"" + + # FIRST, define the component + Comp.DefineComponent $component $errRoot + + # NEXT, handle the options. + set publicMethod "" + set inheritFlag 0 + + foreach {opt val} $args { + switch -exact -- $opt { + -public { + set publicMethod $val + } + -inherit { + set inheritFlag $val + if {![string is boolean $inheritFlag]} { + error "component $component -inherit: expected boolean value, got \"$val\"" + } + } + default { + error "component $component: Invalid option \"$opt\"" + } + } + } + + # NEXT, if -public specified, define the method. + if {"" != $publicMethod} { + Comp.statement.delegate method [list $publicMethod *] to $component + } + + # NEXT, if -inherit is specified, delegate method/option * to + # this component. + if {$inheritFlag} { + Comp.statement.delegate method "*" to $component + Comp.statement.delegate option "*" to $component + } +} + + +# Defines a name to be a component +# +# The name becomes an instance variable; in addition, it gets a +# write trace so that when it is set, all of the component mechanisms +# get updated. +# +# component The component name + +proc ::snit::Comp.DefineComponent {component {errRoot "Error"}} { + variable compile + + if {[lsearch -exact $compile(typevarnames) $component] != -1} { + error "$errRoot, \"$component\" is already a typevariable" + } + + if {[lsearch -exact $compile(components) $component] == -1} { + # Remember we've done this. + lappend compile(components) $component + + # Make it an instance variable with no initial value + Comp.statement.variable $component "" + + # Add a write trace to do the component thing. + Mappend compile(instancevars) { + trace add variable ${selfns}::%COMP% write \ + [list ::snit::RT.ComponentTrace [list %TYPE%] $selfns %COMP%] + } %TYPE% $compile(type) %COMP% $component + } +} + +# Creates a delegated method, typemethod, or option. +proc ::snit::Comp.statement.delegate {what name args} { + # FIRST, dispatch to correct handler. + switch $what { + typemethod { Comp.DelegatedTypemethod $name $args } + method { Comp.DelegatedMethod $name $args } + option { Comp.DelegatedOption $name $args } + default { + error "Error in \"delegate $what $name...\", \"$what\"?" + } + } + + if {([llength $args] % 2) != 0} { + error "Error in \"delegate $what $name...\", invalid syntax" + } +} + +# Creates a delegated typemethod delegating it to a particular +# typecomponent or an arbitrary command. +# +# method The name of the method +# arglist Delegation options + +proc ::snit::Comp.DelegatedTypemethod {method arglist} { + variable compile + variable typemethodInfo + + set errRoot "Error in \"delegate typemethod [list $method]...\"" + + # Next, parse the delegation options. + set component "" + set target "" + set exceptions {} + set pattern "" + set methodTail [lindex $method end] + + foreach {opt value} $arglist { + switch -exact $opt { + to { set component $value } + as { set target $value } + except { set exceptions $value } + using { set pattern $value } + default { + error "$errRoot, unknown delegation option \"$opt\"" + } + } + } + + if {"" == $component && "" == $pattern} { + error "$errRoot, missing \"to\"" + } + + if {"*" == $methodTail && "" != $target} { + error "$errRoot, cannot specify \"as\" with \"*\"" + } + + if {"*" != $methodTail && "" != $exceptions} { + error "$errRoot, can only specify \"except\" with \"*\"" + } + + if {"" != $pattern && "" != $target} { + error "$errRoot, cannot specify both \"as\" and \"using\"" + } + + foreach token [lrange $method 1 end-1] { + if {"*" == $token} { + error "$errRoot, \"*\" must be the last token." + } + } + + # NEXT, define the component + if {"" != $component} { + Comp.DefineTypecomponent $component $errRoot + } + + # NEXT, define the pattern. + if {"" == $pattern} { + if {"*" == $methodTail} { + set pattern "%c %m" + } elseif {"" != $target} { + set pattern "%c $target" + } else { + set pattern "%c %m" + } + } + + # Make sure the pattern is a valid list. + if {[catch {lindex $pattern 0} result]} { + error "$errRoot, the using pattern, \"$pattern\", is not a valid list" + } + + # NEXT, check the method name against previously defined + # methods. + Comp.CheckMethodName $method 1 ::snit::typemethodInfo $errRoot + + set typemethodInfo($method) [list 0 $pattern $component] + + if {[string equal $methodTail "*"]} { + Mappend compile(defs) { + set %TYPE%::Snit_info(excepttypemethods) %EXCEPT% + } %EXCEPT% [list $exceptions] + } +} + + +# Creates a delegated method delegating it to a particular +# component or command. +# +# method The name of the method +# arglist Delegation options. + +proc ::snit::Comp.DelegatedMethod {method arglist} { + variable compile + variable methodInfo + + set errRoot "Error in \"delegate method [list $method]...\"" + + # Next, parse the delegation options. + set component "" + set target "" + set exceptions {} + set pattern "" + set methodTail [lindex $method end] + + foreach {opt value} $arglist { + switch -exact $opt { + to { set component $value } + as { set target $value } + except { set exceptions $value } + using { set pattern $value } + default { + error "$errRoot, unknown delegation option \"$opt\"" + } + } + } + + if {"" == $component && "" == $pattern} { + error "$errRoot, missing \"to\"" + } + + if {"*" == $methodTail && "" != $target} { + error "$errRoot, cannot specify \"as\" with \"*\"" + } + + if {"*" != $methodTail && "" != $exceptions} { + error "$errRoot, can only specify \"except\" with \"*\"" + } + + if {"" != $pattern && "" != $target} { + error "$errRoot, cannot specify both \"as\" and \"using\"" + } + + foreach token [lrange $method 1 end-1] { + if {"*" == $token} { + error "$errRoot, \"*\" must be the last token." + } + } + + # NEXT, we delegate some methods + set compile(delegatesmethods) yes + + # NEXT, define the component. Allow typecomponents. + if {"" != $component} { + if {[lsearch -exact $compile(typecomponents) $component] == -1} { + Comp.DefineComponent $component $errRoot + } + } + + # NEXT, define the pattern. + if {"" == $pattern} { + if {"*" == $methodTail} { + set pattern "%c %m" + } elseif {"" != $target} { + set pattern "%c $target" + } else { + set pattern "%c %m" + } + } + + # Make sure the pattern is a valid list. + if {[catch {lindex $pattern 0} result]} { + error "$errRoot, the using pattern, \"$pattern\", is not a valid list" + } + + # NEXT, check the method name against previously defined + # methods. + Comp.CheckMethodName $method 1 ::snit::methodInfo $errRoot + + # NEXT, save the method info. + set methodInfo($method) [list 0 $pattern $component] + + if {[string equal $methodTail "*"]} { + Mappend compile(defs) { + set %TYPE%::Snit_info(exceptmethods) %EXCEPT% + } %EXCEPT% [list $exceptions] + } +} + +# Creates a delegated option, delegating it to a particular +# component and, optionally, to a particular option of that +# component. +# +# optionDef The option definition +# args definition arguments. + +proc ::snit::Comp.DelegatedOption {optionDef arglist} { + variable compile + + # First, get the three option names. + set option [lindex $optionDef 0] + set resourceName [lindex $optionDef 1] + set className [lindex $optionDef 2] + + set errRoot "Error in \"delegate option [list $optionDef]...\"" + + # Next, parse the delegation options. + set component "" + set target "" + set exceptions {} + + foreach {opt value} $arglist { + switch -exact $opt { + to { set component $value } + as { set target $value } + except { set exceptions $value } + default { + error "$errRoot, unknown delegation option \"$opt\"" + } + } + } + + if {"" == $component} { + error "$errRoot, missing \"to\"" + } + + if {"*" == $option && "" != $target} { + error "$errRoot, cannot specify \"as\" with \"delegate option *\"" + } + + if {"*" != $option && "" != $exceptions} { + error "$errRoot, can only specify \"except\" with \"delegate option *\"" + } + + # Next, validate the option name + + if {"*" != $option} { + if {![Comp.OptionNameIsValid $option]} { + error "$errRoot, badly named option \"$option\"" + } + } + + if {[Contains $option $compile(localoptions)]} { + error "$errRoot, \"$option\" has been defined locally" + } + + if {[Contains $option $compile(delegatedoptions)]} { + error "$errRoot, \"$option\" is multiply delegated" + } + + # NEXT, define the component + Comp.DefineComponent $component $errRoot + + # Next, define the target option, if not specified. + if {![string equal $option "*"] && + [string equal $target ""]} { + set target $option + } + + # NEXT, save the delegation data. + set compile(hasoptions) yes + + if {![string equal $option "*"]} { + lappend compile(delegatedoptions) $option + + # Next, compute the resource and class names, if they aren't + # already defined. + + if {"" == $resourceName} { + set resourceName [string range $option 1 end] + } + + if {"" == $className} { + set className [Capitalize $resourceName] + } + + Mappend compile(defs) { + set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 0 + set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RES% + set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS% + lappend %TYPE%::Snit_optionInfo(delegated) %OPTION% + set %TYPE%::Snit_optionInfo(target-%OPTION%) [list %COMP% %TARGET%] + lappend %TYPE%::Snit_optionInfo(delegated-%COMP%) %OPTION% + } %OPTION% $option \ + %COMP% $component \ + %TARGET% $target \ + %RES% $resourceName \ + %CLASS% $className + } else { + Mappend compile(defs) { + set %TYPE%::Snit_optionInfo(starcomp) %COMP% + set %TYPE%::Snit_optionInfo(except) %EXCEPT% + } %COMP% $component %EXCEPT% [list $exceptions] + } +} + +# Exposes a component, effectively making the component's command an +# instance method. +# +# component The logical name of the delegate +# "as" sugar; if not "", must be "as" +# methodname The desired method name for the component's command, or "" + +proc ::snit::Comp.statement.expose {component {"as" ""} {methodname ""}} { + variable compile + + + # FIRST, define the component + Comp.DefineComponent $component + + # NEXT, define the method just as though it were in the type + # definition. + if {[string equal $methodname ""]} { + set methodname $component + } + + Comp.statement.method $methodname args [Expand { + if {[llength $args] == 0} { + return $%COMPONENT% + } + + if {[string equal $%COMPONENT% ""]} { + error "undefined component \"%COMPONENT%\"" + } + + + set cmd [linsert $args 0 $%COMPONENT%] + return [uplevel 1 $cmd] + } %COMPONENT% $component] +} + + + +#----------------------------------------------------------------------- +# Public commands + +# Compile a type definition, and return the results as a list of two +# items: the fully-qualified type name, and a script that will define +# the type when executed. +# +# which type, widget, or widgetadaptor +# type the type name +# body the type definition +proc ::snit::compile {which type body} { + return [Comp.Compile $which $type $body] +} + +proc ::snit::type {type body} { + return [Comp.Define [Comp.Compile type $type $body]] +} + +proc ::snit::widget {type body} { + return [Comp.Define [Comp.Compile widget $type $body]] +} + +proc ::snit::widgetadaptor {type body} { + return [Comp.Define [Comp.Compile widgetadaptor $type $body]] +} + +proc ::snit::typemethod {type method arglist body} { + # Make sure the type exists. + if {![info exists ${type}::Snit_info]} { + error "no such type: \"$type\"" + } + + upvar ${type}::Snit_info Snit_info + upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo + + # FIRST, check the typemethod name against previously defined + # typemethods. + Comp.CheckMethodName $method 0 ${type}::Snit_typemethodInfo \ + "Cannot define \"$method\"" + + # NEXT, check the arguments + CheckArgs "snit::typemethod $type $method" $arglist + + # Next, add magic reference to type. + set arglist [concat type $arglist] + + # Next, add typevariable declarations to body: + set body "$Snit_info(tvardecs)\n$body" + + # Next, define it. + if {[llength $method] == 1} { + set Snit_typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""} + uplevel 1 [list proc ${type}::Snit_typemethod$method $arglist $body] + } else { + set Snit_typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""} + set suffix [join $method _] + uplevel 1 [list proc ${type}::Snit_htypemethod$suffix $arglist $body] + } +} + +proc ::snit::method {type method arglist body} { + # Make sure the type exists. + if {![info exists ${type}::Snit_info]} { + error "no such type: \"$type\"" + } + + upvar ${type}::Snit_methodInfo Snit_methodInfo + upvar ${type}::Snit_info Snit_info + + # FIRST, check the method name against previously defined + # methods. + Comp.CheckMethodName $method 0 ${type}::Snit_methodInfo \ + "Cannot define \"$method\"" + + # NEXT, check the arguments + CheckArgs "snit::method $type $method" $arglist + + # Next, add magic references to type and self. + set arglist [concat type selfns win self $arglist] + + # Next, add variable declarations to body: + set body "$Snit_info(tvardecs)$Snit_info(ivardecs)\n$body" + + # Next, define it. + if {[llength $method] == 1} { + set Snit_methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""} + uplevel 1 [list proc ${type}::Snit_method$method $arglist $body] + } else { + set Snit_methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""} + + set suffix [join $method _] + uplevel 1 [list proc ${type}::Snit_hmethod$suffix $arglist $body] + } +} + +# Defines a proc within the compiler; this proc can call other +# type definition statements, and thus can be used for meta-programming. +proc ::snit::macro {name arglist body} { + variable compiler + variable reservedwords + + # FIRST, make sure the compiler is defined. + Comp.Init + + # NEXT, check the macro name against the reserved words + if {[lsearch -exact $reservedwords $name] != -1} { + error "invalid macro name \"$name\"" + } + + # NEXT, see if the name has a namespace; if it does, define the + # namespace. + set ns [namespace qualifiers $name] + + if {"" != $ns} { + $compiler eval "namespace eval $ns {}" + } + + # NEXT, define the macro + $compiler eval [list _proc $name $arglist $body] +} + +#----------------------------------------------------------------------- +# Utility Functions +# +# These are utility functions used while compiling Snit types. + +# Builds a template from a tagged list of text blocks, then substitutes +# all symbols in the mapTable, returning the expanded template. +proc ::snit::Expand {template args} { + return [string map $args $template] +} + +# Expands a template and appends it to a variable. +proc ::snit::Mappend {varname template args} { + upvar $varname myvar + + append myvar [string map $args $template] +} + +# Checks argument list against reserved args +proc ::snit::CheckArgs {which arglist} { + variable reservedArgs + + foreach name $reservedArgs { + if {[Contains $name $arglist]} { + error "$which's arglist may not contain \"$name\" explicitly" + } + } +} + +# Returns 1 if a value is in a list, and 0 otherwise. +proc ::snit::Contains {value list} { + if {[lsearch -exact $list $value] != -1} { + return 1 + } else { + return 0 + } +} + +# Capitalizes the first letter of a string. +proc ::snit::Capitalize {text} { + return [string toupper $text 0] +} + +# Converts an arbitrary white-space-delimited string into a list +# by splitting on white-space and deleting empty tokens. + +proc ::snit::Listify {str} { + set result {} + foreach token [split [string trim $str]] { + if {[string length $token] > 0} { + lappend result $token + } + } + + return $result +} + + +#======================================================================= +# Snit Runtime Library +# +# These are procs used by Snit types and widgets at runtime. + +#----------------------------------------------------------------------- +# Object Creation + +# Creates a new instance of the snit::type given its name and the args. +# +# type The snit::type +# name The instance name +# args Args to pass to the constructor + +proc ::snit::RT.type.typemethod.create {type name args} { + variable ${type}::Snit_info + variable ${type}::Snit_optionInfo + + # FIRST, qualify the name. + if {![string match "::*" $name]} { + # Get caller's namespace; + # append :: if not global namespace. + set ns [uplevel 1 [list namespace current]] + if {"::" != $ns} { + append ns "::" + } + + set name "$ns$name" + } + + # NEXT, if %AUTO% appears in the name, generate a unique + # command name. Otherwise, ensure that the name isn't in use. + if {[string match "*%AUTO%*" $name]} { + set name [::snit::RT.UniqueName Snit_info(counter) $type $name] + } elseif {!$Snit_info(canreplace) && [llength [info commands $name]]} { + error "command \"$name\" already exists" + } + + # NEXT, create the instance's namespace. + set selfns \ + [::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type] + namespace eval $selfns {} + + # NEXT, install the dispatcher + RT.MakeInstanceCommand $type $selfns $name + + # Initialize the options to their defaults. + upvar ${selfns}::options options + foreach opt $Snit_optionInfo(local) { + set options($opt) $Snit_optionInfo(default-$opt) + } + + # Initialize the instance vars to their defaults. + # selfns must be defined, as it is used implicitly. + ${type}::Snit_instanceVars $selfns + + # Execute the type's constructor. + set errcode [catch { + RT.ConstructInstance $type $selfns $name $args + } result] + + if {$errcode} { + global errorInfo + global errorCode + + set theInfo $errorInfo + set theCode $errorCode + ::snit::RT.DestroyObject $type $selfns $name + error "Error in constructor: $result" $theInfo $theCode + } + + # NEXT, return the object's name. + return $name +} + +# Creates a new instance of the snit::widget or snit::widgetadaptor +# given its name and the args. +# +# type The snit::widget or snit::widgetadaptor +# name The instance name +# args Args to pass to the constructor + +proc ::snit::RT.widget.typemethod.create {type name args} { + variable ${type}::Snit_info + variable ${type}::Snit_optionInfo + + # FIRST, if %AUTO% appears in the name, generate a unique + # command name. + if {[string match "*%AUTO%*" $name]} { + set name [::snit::RT.UniqueName Snit_info(counter) $type $name] + } + + # NEXT, create the instance's namespace. + set selfns \ + [::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type] + namespace eval $selfns { } + + # NEXT, Initialize the widget's own options to their defaults. + upvar ${selfns}::options options + foreach opt $Snit_optionInfo(local) { + set options($opt) $Snit_optionInfo(default-$opt) + } + + # Initialize the instance vars to their defaults. + ${type}::Snit_instanceVars $selfns + + # NEXT, if this is a normal widget (not a widget adaptor) then create a + # frame as its hull. We set the frame's -class to the user's widgetclass, + # or, if none, search for -class in the args list, otherwise default to + # the basename of the $type with an initial upper case letter. + if {!$Snit_info(isWidgetAdaptor)} { + # FIRST, determine the class name + set wclass $Snit_info(widgetclass) + if {$Snit_info(widgetclass) eq ""} { + set idx [lsearch -exact $args -class] + if {$idx >= 0 && ($idx%2 == 0)} { + # -class exists and is in the -option position + set wclass [lindex $args [expr {$idx+1}]] + set args [lreplace $args $idx [expr {$idx+1}]] + } else { + set wclass [::snit::Capitalize [namespace tail $type]] + } + } + + # NEXT, create the widget + set self $name + package require Tk + ${type}::installhull using $Snit_info(hulltype) -class $wclass + + # NEXT, let's query the option database for our + # widget, now that we know that it exists. + foreach opt $Snit_optionInfo(local) { + set dbval [RT.OptionDbGet $type $name $opt] + + if {"" != $dbval} { + set options($opt) $dbval + } + } + } + + # Execute the type's constructor, and verify that it + # has a hull. + set errcode [catch { + RT.ConstructInstance $type $selfns $name $args + + ::snit::RT.Component $type $selfns hull + + # Prepare to call the object's destructor when the + # event is received. Use a Snit-specific bindtag + # so that the widget name's tag is unencumbered. + + bind Snit$type$name [::snit::Expand { + ::snit::RT.DestroyObject %TYPE% %NS% %W + } %TYPE% $type %NS% $selfns] + + # Insert the bindtag into the list of bindtags right + # after the widget name. + set taglist [bindtags $name] + set ndx [lsearch -exact $taglist $name] + incr ndx + bindtags $name [linsert $taglist $ndx Snit$type$name] + } result] + + if {$errcode} { + global errorInfo + global errorCode + + set theInfo $errorInfo + set theCode $errorCode + ::snit::RT.DestroyObject $type $selfns $name + error "Error in constructor: $result" $theInfo $theCode + } + + # NEXT, return the object's name. + return $name +} + + +# RT.MakeInstanceCommand type selfns instance +# +# type The object type +# selfns The instance namespace +# instance The instance name +# +# Creates the instance proc. + +proc ::snit::RT.MakeInstanceCommand {type selfns instance} { + variable ${type}::Snit_info + + # FIRST, remember the instance name. The Snit_instance variable + # allows the instance to figure out its current name given the + # instance namespace. + upvar ${selfns}::Snit_instance Snit_instance + set Snit_instance $instance + + # NEXT, qualify the proc name if it's a widget. + if {$Snit_info(isWidget)} { + set procname ::$instance + } else { + set procname $instance + } + + # NEXT, install the new proc + if {!$Snit_info(simpledispatch)} { + set instanceProc $::snit::nominalInstanceProc + } else { + set instanceProc $::snit::simpleInstanceProc + } + + proc $procname {method args} \ + [string map \ + [list %SELFNS% $selfns %WIN% $instance %TYPE% $type] \ + $instanceProc] + + # NEXT, add the trace. + trace add command $procname {rename delete} \ + [list ::snit::RT.InstanceTrace $type $selfns $instance] +} + +# This proc is called when the instance command is renamed. +# If op is delete, then new will always be "", so op is redundant. +# +# type The fully-qualified type name +# selfns The instance namespace +# win The original instance/tk window name. +# old old instance command name +# new new instance command name +# op rename or delete +# +# If the op is delete, we need to clean up the object; otherwise, +# we need to track the change. +# +# NOTE: In Tcl 8.4.2 there's a bug: errors in rename and delete +# traces aren't propagated correctly. Instead, they silently +# vanish. Add a catch to output any error message. + +proc ::snit::RT.InstanceTrace {type selfns win old new op} { + variable ${type}::Snit_info + + # Note to developers ... + # For Tcl 8.4.0, errors thrown in trace handlers vanish silently. + # Therefore we catch them here and create some output to help in + # debugging such problems. + + if {[catch { + # FIRST, clean up if necessary + if {"" == $new} { + if {$Snit_info(isWidget)} { + destroy $win + } else { + ::snit::RT.DestroyObject $type $selfns $win + } + } else { + # Otherwise, track the change. + variable ${selfns}::Snit_instance + set Snit_instance [uplevel 1 [list namespace which -command $new]] + + # Also, clear the instance caches, as many cached commands + # might be invalid. + RT.ClearInstanceCaches $selfns + } + } result]} { + global errorInfo + # Pop up the console on Windows wish, to enable stdout. + # This clobbers errorInfo on unix, so save it so we can print it. + set ei $errorInfo + catch {console show} + puts "Error in ::snit::RT.InstanceTrace $type $selfns $win $old $new $op:" + puts $ei + } +} + +# Calls the instance constructor and handles related housekeeping. +proc ::snit::RT.ConstructInstance {type selfns instance arglist} { + variable ${type}::Snit_optionInfo + variable ${selfns}::Snit_iinfo + + # Track whether we are constructed or not. + set Snit_iinfo(constructed) 0 + + # Call the user's constructor + eval [linsert $arglist 0 \ + ${type}::Snit_constructor $type $selfns $instance $instance] + + set Snit_iinfo(constructed) 1 + + # Validate the initial set of options (including defaults) + foreach option $Snit_optionInfo(local) { + set value [set ${selfns}::options($option)] + + if {"" != $Snit_optionInfo(typespec-$option)} { + if {[catch { + $Snit_optionInfo(typeobj-$option) validate $value + } result]} { + return -code error "invalid $option default: $result" + } + } + } + + # Unset the configure cache for all -readonly options. + # This ensures that the next time anyone tries to + # configure it, an error is thrown. + foreach opt $Snit_optionInfo(local) { + if {$Snit_optionInfo(readonly-$opt)} { + unset -nocomplain ${selfns}::Snit_configureCache($opt) + } + } + + return +} + +# Returns a unique command name. +# +# REQUIRE: type is a fully qualified name. +# REQUIRE: name contains "%AUTO%" +# PROMISE: the returned command name is unused. +proc ::snit::RT.UniqueName {countervar type name} { + upvar $countervar counter + while 1 { + # FIRST, bump the counter and define the %AUTO% instance name; + # then substitute it into the specified name. Wrap around at + # 2^31 - 2 to prevent overflow problems. + incr counter + if {$counter > 2147483646} { + set counter 0 + } + set auto "[namespace tail $type]$counter" + set candidate [Expand $name %AUTO% $auto] + if {![llength [info commands $candidate]]} { + return $candidate + } + } +} + +# Returns a unique instance namespace, fully qualified. +# +# countervar The name of a counter variable +# type The instance's type +# +# REQUIRE: type is fully qualified +# PROMISE: The returned namespace name is unused. + +proc ::snit::RT.UniqueInstanceNamespace {countervar type} { + upvar $countervar counter + while 1 { + # FIRST, bump the counter and define the namespace name. + # Then see if it already exists. Wrap around at + # 2^31 - 2 to prevent overflow problems. + incr counter + if {$counter > 2147483646} { + set counter 0 + } + set ins "${type}::Snit_inst${counter}" + if {![namespace exists $ins]} { + return $ins + } + } +} + +# Retrieves an option's value from the option database. +# Returns "" if no value is found. +proc ::snit::RT.OptionDbGet {type self opt} { + variable ${type}::Snit_optionInfo + + return [option get $self \ + $Snit_optionInfo(resource-$opt) \ + $Snit_optionInfo(class-$opt)] +} + +#----------------------------------------------------------------------- +# Object Destruction + +# Implements the standard "destroy" method +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name + +proc ::snit::RT.method.destroy {type selfns win self} { + variable ${selfns}::Snit_iinfo + + # Can't destroy the object if it isn't complete constructed. + if {!$Snit_iinfo(constructed)} { + return -code error "Called 'destroy' method in constructor" + } + + # Calls Snit_cleanup, which (among other things) calls the + # user's destructor. + ::snit::RT.DestroyObject $type $selfns $win +} + +# This is the function that really cleans up; it's automatically +# called when any instance is destroyed, e.g., by "$object destroy" +# for types, and by the event for widgets. +# +# type The fully-qualified type name. +# selfns The instance namespace +# win The original instance command name. + +proc ::snit::RT.DestroyObject {type selfns win} { + variable ${type}::Snit_info + + # If the variable Snit_instance doesn't exist then there's no + # instance command for this object -- it's most likely a + # widgetadaptor. Consequently, there are some things that + # we don't need to do. + if {[info exists ${selfns}::Snit_instance]} { + upvar ${selfns}::Snit_instance instance + + # First, remove the trace on the instance name, so that we + # don't call RT.DestroyObject recursively. + RT.RemoveInstanceTrace $type $selfns $win $instance + + # Next, call the user's destructor + ${type}::Snit_destructor $type $selfns $win $instance + + # Next, if this isn't a widget, delete the instance command. + # If it is a widget, get the hull component's name, and rename + # it back to the widget name + + # Next, delete the hull component's instance command, + # if there is one. + if {$Snit_info(isWidget)} { + set hullcmd [::snit::RT.Component $type $selfns hull] + + catch {rename $instance ""} + + # Clear the bind event + bind Snit$type$win "" + + if {[llength [info commands $hullcmd]]} { + # FIRST, rename the hull back to its original name. + # If the hull is itself a megawidget, it will have its + # own cleanup to do, and it might not do it properly + # if it doesn't have the right name. + rename $hullcmd ::$instance + + # NEXT, destroy it. + destroy $instance + } + } else { + catch {rename $instance ""} + } + } + + # Next, delete the instance's namespace. This kills any + # instance variables. + namespace delete $selfns + + return +} + +# Remove instance trace +# +# type The fully qualified type name +# selfns The instance namespace +# win The original instance name/Tk window name +# instance The current instance name + +proc ::snit::RT.RemoveInstanceTrace {type selfns win instance} { + variable ${type}::Snit_info + + if {$Snit_info(isWidget)} { + set procname ::$instance + } else { + set procname $instance + } + + # NEXT, remove any trace on this name + catch { + trace remove command $procname {rename delete} \ + [list ::snit::RT.InstanceTrace $type $selfns $win] + } +} + +#----------------------------------------------------------------------- +# Typecomponent Management and Method Caching + +# Typecomponent trace; used for write trace on typecomponent +# variables. Saves the new component object name, provided +# that certain conditions are met. Also clears the typemethod +# cache. + +proc ::snit::RT.TypecomponentTrace {type component n1 n2 op} { + upvar ${type}::Snit_info Snit_info + upvar ${type}::${component} cvar + upvar ${type}::Snit_typecomponents Snit_typecomponents + + # Save the new component value. + set Snit_typecomponents($component) $cvar + + # Clear the typemethod cache. + # TBD: can we unset just the elements related to + # this component? + unset -nocomplain -- ${type}::Snit_typemethodCache +} + +# Generates and caches the command for a typemethod. +# +# type The type +# method The name of the typemethod to call. +# +# The return value is one of the following lists: +# +# {} There's no such method. +# {1} The method has submethods; look again. +# {0 } Here's the command to execute. + +proc snit::RT.CacheTypemethodCommand {type method} { + upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo + upvar ${type}::Snit_typecomponents Snit_typecomponents + upvar ${type}::Snit_typemethodCache Snit_typemethodCache + upvar ${type}::Snit_info Snit_info + + # FIRST, get the pattern data and the typecomponent name. + set implicitCreate 0 + set instanceName "" + + set starredMethod [lreplace $method end end *] + set methodTail [lindex $method end] + + if {[info exists Snit_typemethodInfo($method)]} { + set key $method + } elseif {[info exists Snit_typemethodInfo($starredMethod)]} { + if {[lsearch -exact $Snit_info(excepttypemethods) $methodTail] == -1} { + set key $starredMethod + } else { + return [list ] + } + } elseif {[llength $method] > 1} { + return [list ] + } elseif {$Snit_info(hasinstances)} { + # Assume the unknown name is an instance name to create, unless + # this is a widget and the style of the name is wrong, or the + # name mimics a standard typemethod. + + if {[set ${type}::Snit_info(isWidget)] && + ![string match ".*" $method]} { + return [list ] + } + + # Without this check, the call "$type info" will redefine the + # standard "::info" command, with disastrous results. Since it's + # a likely thing to do if !-typeinfo, put in an explicit check. + if {"info" == $method || "destroy" == $method} { + return [list ] + } + + set implicitCreate 1 + set instanceName $method + set key create + set method create + } else { + return [list ] + } + + foreach {flag pattern compName} $Snit_typemethodInfo($key) {} + + if {$flag == 1} { + return [list 1] + } + + # NEXT, build the substitution list + set subList [list \ + %% % \ + %t $type \ + %M $method \ + %m [lindex $method end] \ + %j [join $method _]] + + if {"" != $compName} { + if {![info exists Snit_typecomponents($compName)]} { + error "$type delegates typemethod \"$method\" to undefined typecomponent \"$compName\"" + } + + lappend subList %c [list $Snit_typecomponents($compName)] + } + + set command {} + + foreach subpattern $pattern { + lappend command [string map $subList $subpattern] + } + + if {$implicitCreate} { + # In this case, $method is the name of the instance to + # create. Don't cache, as we usually won't do this one + # again. + lappend command $instanceName + } else { + set Snit_typemethodCache($method) [list 0 $command] + } + + return [list 0 $command] +} + + +#----------------------------------------------------------------------- +# Component Management and Method Caching + +# Retrieves the object name given the component name. +proc ::snit::RT.Component {type selfns name} { + variable ${selfns}::Snit_components + + if {[catch {set Snit_components($name)} result]} { + variable ${selfns}::Snit_instance + + error "component \"$name\" is undefined in $type $Snit_instance" + } + + return $result +} + +# Component trace; used for write trace on component instance +# variables. Saves the new component object name, provided +# that certain conditions are met. Also clears the method +# cache. + +proc ::snit::RT.ComponentTrace {type selfns component n1 n2 op} { + upvar ${type}::Snit_info Snit_info + upvar ${selfns}::${component} cvar + upvar ${selfns}::Snit_components Snit_components + + # If they try to redefine the hull component after + # it's been defined, that's an error--but only if + # this is a widget or widget adaptor. + if {"hull" == $component && + $Snit_info(isWidget) && + [info exists Snit_components($component)]} { + set cvar $Snit_components($component) + error "The hull component cannot be redefined" + } + + # Save the new component value. + set Snit_components($component) $cvar + + # Clear the instance caches. + # TBD: can we unset just the elements related to + # this component? + RT.ClearInstanceCaches $selfns +} + +# Generates and caches the command for a method. +# +# type: The instance's type +# selfns: The instance's private namespace +# win: The instance's original name (a Tk widget name, for +# snit::widgets. +# self: The instance's current name. +# method: The name of the method to call. +# +# The return value is one of the following lists: +# +# {} There's no such method. +# {1} The method has submethods; look again. +# {0 } Here's the command to execute. + +proc ::snit::RT.CacheMethodCommand {type selfns win self method} { + variable ${type}::Snit_info + variable ${type}::Snit_methodInfo + variable ${type}::Snit_typecomponents + variable ${selfns}::Snit_components + variable ${selfns}::Snit_methodCache + + # FIRST, get the pattern data and the component name. + set starredMethod [lreplace $method end end *] + set methodTail [lindex $method end] + + if {[info exists Snit_methodInfo($method)]} { + set key $method + } elseif {[info exists Snit_methodInfo($starredMethod)] && + [lsearch -exact $Snit_info(exceptmethods) $methodTail] == -1} { + set key $starredMethod + } else { + return [list ] + } + + foreach {flag pattern compName} $Snit_methodInfo($key) {} + + if {$flag == 1} { + return [list 1] + } + + # NEXT, build the substitution list + set subList [list \ + %% % \ + %t $type \ + %M $method \ + %m [lindex $method end] \ + %j [join $method _] \ + %n [list $selfns] \ + %w [list $win] \ + %s [list $self]] + + if {"" != $compName} { + if {[info exists Snit_components($compName)]} { + set compCmd $Snit_components($compName) + } elseif {[info exists Snit_typecomponents($compName)]} { + set compCmd $Snit_typecomponents($compName) + } else { + error "$type $self delegates method \"$method\" to undefined component \"$compName\"" + } + + lappend subList %c [list $compCmd] + } + + # Note: The cached command will executed faster if it's + # already a list. + set command {} + + foreach subpattern $pattern { + lappend command [string map $subList $subpattern] + } + + set commandRec [list 0 $command] + + set Snit_methodCache($method) $commandRec + + return $commandRec +} + + +# Looks up a method's command. +# +# type: The instance's type +# selfns: The instance's private namespace +# win: The instance's original name (a Tk widget name, for +# snit::widgets. +# self: The instance's current name. +# method: The name of the method to call. +# errPrefix: Prefix for any error method +proc ::snit::RT.LookupMethodCommand {type selfns win self method errPrefix} { + set commandRec [snit::RT.CacheMethodCommand \ + $type $selfns $win $self \ + $method] + + + if {[llength $commandRec] == 0} { + return -code error \ + "$errPrefix, \"$self $method\" is not defined" + } elseif {[lindex $commandRec 0] == 1} { + return -code error \ + "$errPrefix, wrong number args: should be \"$self\" $method method args" + } + + return [lindex $commandRec 1] +} + + +# Clears all instance command caches +proc ::snit::RT.ClearInstanceCaches {selfns} { + unset -nocomplain -- ${selfns}::Snit_methodCache + unset -nocomplain -- ${selfns}::Snit_cgetCache + unset -nocomplain -- ${selfns}::Snit_configureCache + unset -nocomplain -- ${selfns}::Snit_validateCache +} + + +#----------------------------------------------------------------------- +# Component Installation + +# Implements %TYPE%::installhull. The variables self and selfns +# must be defined in the caller's context. +# +# Installs the named widget as the hull of a +# widgetadaptor. Once the widget is hijacked, its new name +# is assigned to the hull component. + +proc ::snit::RT.installhull {type {using "using"} {widgetType ""} args} { + variable ${type}::Snit_info + variable ${type}::Snit_optionInfo + upvar self self + upvar selfns selfns + upvar ${selfns}::hull hull + upvar ${selfns}::options options + + # FIRST, make sure we can do it. + if {!$Snit_info(isWidget)} { + error "installhull is valid only for snit::widgetadaptors" + } + + if {[info exists ${selfns}::Snit_instance]} { + error "hull already installed for $type $self" + } + + # NEXT, has it been created yet? If not, create it using + # the specified arguments. + if {"using" == $using} { + # FIRST, create the widget + set cmd [linsert $args 0 $widgetType $self] + set obj [uplevel 1 $cmd] + + # NEXT, for each option explicitly delegated to the hull + # that doesn't appear in the usedOpts list, get the + # option database value and apply it--provided that the + # real option name and the target option name are different. + # (If they are the same, then the option database was + # already queried as part of the normal widget creation.) + # + # Also, we don't need to worry about implicitly delegated + # options, as the option and target option names must be + # the same. + if {[info exists Snit_optionInfo(delegated-hull)]} { + + # FIRST, extract all option names from args + set usedOpts {} + set ndx [lsearch -glob $args "-*"] + foreach {opt val} [lrange $args $ndx end] { + lappend usedOpts $opt + } + + foreach opt $Snit_optionInfo(delegated-hull) { + set target [lindex $Snit_optionInfo(target-$opt) 1] + + if {"$target" == $opt} { + continue + } + + set result [lsearch -exact $usedOpts $target] + + if {$result != -1} { + continue + } + + set dbval [RT.OptionDbGet $type $self $opt] + $obj configure $target $dbval + } + } + } else { + set obj $using + + if {![string equal $obj $self]} { + error \ + "hull name mismatch: \"$obj\" != \"$self\"" + } + } + + # NEXT, get the local option defaults. + foreach opt $Snit_optionInfo(local) { + set dbval [RT.OptionDbGet $type $self $opt] + + if {"" != $dbval} { + set options($opt) $dbval + } + } + + + # NEXT, do the magic + set i 0 + while 1 { + incr i + set newName "::hull${i}$self" + if {![llength [info commands $newName]]} { + break + } + } + + rename ::$self $newName + RT.MakeInstanceCommand $type $selfns $self + + # Note: this relies on RT.ComponentTrace to do the dirty work. + set hull $newName + + return +} + +# Implements %TYPE%::install. +# +# Creates a widget and installs it as the named component. +# It expects self and selfns to be defined in the caller's context. + +proc ::snit::RT.install {type compName "using" widgetType winPath args} { + variable ${type}::Snit_optionInfo + variable ${type}::Snit_info + upvar self self + upvar selfns selfns + upvar ${selfns}::$compName comp + upvar ${selfns}::hull hull + + # We do the magic option database stuff only if $self is + # a widget. + if {$Snit_info(isWidget)} { + if {"" == $hull} { + error "tried to install \"$compName\" before the hull exists" + } + + # FIRST, query the option database and save the results + # into args. Insert them before the first option in the + # list, in case there are any non-standard parameters. + # + # Note: there might not be any delegated options; if so, + # don't bother. + + if {[info exists Snit_optionInfo(delegated-$compName)]} { + set ndx [lsearch -glob $args "-*"] + + foreach opt $Snit_optionInfo(delegated-$compName) { + set dbval [RT.OptionDbGet $type $self $opt] + + if {"" != $dbval} { + set target [lindex $Snit_optionInfo(target-$opt) 1] + set args [linsert $args $ndx $target $dbval] + } + } + } + } + + # NEXT, create the component and save it. + set cmd [concat [list $widgetType $winPath] $args] + set comp [uplevel 1 $cmd] + + # NEXT, handle the option database for "delegate option *", + # in widgets only. + if {$Snit_info(isWidget) && [string equal $Snit_optionInfo(starcomp) $compName]} { + # FIRST, get the list of option specs from the widget. + # If configure doesn't work, skip it. + if {[catch {$comp configure} specs]} { + return + } + + # NEXT, get the set of explicitly used options from args + set usedOpts {} + set ndx [lsearch -glob $args "-*"] + foreach {opt val} [lrange $args $ndx end] { + lappend usedOpts $opt + } + + # NEXT, "delegate option *" matches all options defined + # by this widget that aren't defined by the widget as a whole, + # and that aren't excepted. Plus, we skip usedOpts. So build + # a list of the options it can't match. + set skiplist [concat \ + $usedOpts \ + $Snit_optionInfo(except) \ + $Snit_optionInfo(local) \ + $Snit_optionInfo(delegated)] + + # NEXT, loop over all of the component's options, and set + # any not in the skip list for which there is an option + # database value. + foreach spec $specs { + # Skip aliases + if {[llength $spec] != 5} { + continue + } + + set opt [lindex $spec 0] + + if {[lsearch -exact $skiplist $opt] != -1} { + continue + } + + set res [lindex $spec 1] + set cls [lindex $spec 2] + + set dbvalue [option get $self $res $cls] + + if {"" != $dbvalue} { + $comp configure $opt $dbvalue + } + } + } + + return +} + + +#----------------------------------------------------------------------- +# Method/Variable Name Qualification + +# Implements %TYPE%::variable. Requires selfns. +proc ::snit::RT.variable {varname} { + upvar selfns selfns + + if {![string match "::*" $varname]} { + uplevel 1 [list upvar 1 ${selfns}::$varname $varname] + } else { + # varname is fully qualified; let the standard + # "variable" command handle it. + uplevel 1 [list ::variable $varname] + } +} + +# Fully qualifies a typevariable name. +# +# This is used to implement the mytypevar command. + +proc ::snit::RT.mytypevar {type name} { + return ${type}::$name +} + +# Fully qualifies an instance variable name. +# +# This is used to implement the myvar command. +proc ::snit::RT.myvar {name} { + upvar selfns selfns + return ${selfns}::$name +} + +# Use this like "list" to convert a proc call into a command +# string to pass to another object (e.g., as a -command). +# Qualifies the proc name properly. +# +# This is used to implement the "myproc" command. + +proc ::snit::RT.myproc {type procname args} { + set procname "${type}::$procname" + return [linsert $args 0 $procname] +} + +# DEPRECATED +proc ::snit::RT.codename {type name} { + return "${type}::$name" +} + +# Use this like "list" to convert a typemethod call into a command +# string to pass to another object (e.g., as a -command). +# Inserts the type command at the beginning. +# +# This is used to implement the "mytypemethod" command. + +proc ::snit::RT.mytypemethod {type args} { + return [linsert $args 0 $type] +} + +# Use this like "list" to convert a method call into a command +# string to pass to another object (e.g., as a -command). +# Inserts the code at the beginning to call the right object, even if +# the object's name has changed. Requires that selfns be defined +# in the calling context, eg. can only be called in instance +# code. +# +# This is used to implement the "mymethod" command. + +proc ::snit::RT.mymethod {args} { + upvar selfns selfns + return [linsert $args 0 ::snit::RT.CallInstance ${selfns}] +} + +# Calls an instance method for an object given its +# instance namespace and remaining arguments (the first of which +# will be the method name. +# +# selfns The instance namespace +# args The arguments +# +# Uses the selfns to determine $self, and calls the method +# in the normal way. +# +# This is used to implement the "mymethod" command. + +proc ::snit::RT.CallInstance {selfns args} { + upvar ${selfns}::Snit_instance self + + set retval [catch {uplevel 1 [linsert $args 0 $self]} result] + + if {$retval} { + if {$retval == 1} { + global errorInfo + global errorCode + return -code error -errorinfo $errorInfo \ + -errorcode $errorCode $result + } else { + return -code $retval $result + } + } + + return $result +} + +# Looks for the named option in the named variable. If found, +# it and its value are removed from the list, and the value +# is returned. Otherwise, the default value is returned. +# If the option is undelegated, it's own default value will be +# used if none is specified. +# +# Implements the "from" command. + +proc ::snit::RT.from {type argvName option {defvalue ""}} { + variable ${type}::Snit_optionInfo + upvar $argvName argv + + set ioption [lsearch -exact $argv $option] + + if {$ioption == -1} { + if {"" == $defvalue && + [info exists Snit_optionInfo(default-$option)]} { + return $Snit_optionInfo(default-$option) + } else { + return $defvalue + } + } + + set ivalue [expr {$ioption + 1}] + set value [lindex $argv $ivalue] + + set argv [lreplace $argv $ioption $ivalue] + + return $value +} + +#----------------------------------------------------------------------- +# Type Destruction + +# Implements the standard "destroy" typemethod: +# Destroys a type completely. +# +# type The snit type + +proc ::snit::RT.typemethod.destroy {type} { + variable ${type}::Snit_info + + # FIRST, destroy all instances + foreach selfns [namespace children $type "${type}::Snit_inst*"] { + if {![namespace exists $selfns]} { + continue + } + upvar ${selfns}::Snit_instance obj + + if {$Snit_info(isWidget)} { + destroy $obj + } else { + if {[llength [info commands $obj]]} { + $obj destroy + } + } + } + + # NEXT, destroy the type's data. + namespace delete $type + + # NEXT, get rid of the type command. + rename $type "" +} + + + +#----------------------------------------------------------------------- +# Option Handling + +# Implements the standard "cget" method +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name +# option The name of the option + +proc ::snit::RT.method.cget {type selfns win self option} { + if {[catch {set ${selfns}::Snit_cgetCache($option)} command]} { + set command [snit::RT.CacheCgetCommand $type $selfns $win $self $option] + + if {[llength $command] == 0} { + return -code error "unknown option \"$option\"" + } + } + + uplevel 1 $command +} + +# Retrieves and caches the command that implements "cget" for the +# specified option. +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name +# option The name of the option + +proc ::snit::RT.CacheCgetCommand {type selfns win self option} { + variable ${type}::Snit_optionInfo + variable ${selfns}::Snit_cgetCache + + if {[info exists Snit_optionInfo(islocal-$option)]} { + # We know the item; it's either local, or explicitly delegated. + if {$Snit_optionInfo(islocal-$option)} { + # It's a local option. If it has a cget method defined, + # use it; otherwise just return the value. + + if {"" == $Snit_optionInfo(cget-$option)} { + set command [list set ${selfns}::options($option)] + } else { + set command [snit::RT.LookupMethodCommand \ + $type $selfns $win $self \ + $Snit_optionInfo(cget-$option) \ + "can't cget $option"] + + lappend command $option + } + + set Snit_cgetCache($option) $command + return $command + } + + # Explicitly delegated option; get target + set comp [lindex $Snit_optionInfo(target-$option) 0] + set target [lindex $Snit_optionInfo(target-$option) 1] + } elseif {"" != $Snit_optionInfo(starcomp) && + [lsearch -exact $Snit_optionInfo(except) $option] == -1} { + # Unknown option, but unknowns are delegated; get target. + set comp $Snit_optionInfo(starcomp) + set target $option + } else { + return "" + } + + # Get the component's object. + set obj [RT.Component $type $selfns $comp] + + set command [list $obj cget $target] + set Snit_cgetCache($option) $command + + return $command +} + +# Implements the standard "configurelist" method +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name +# optionlist A list of options and their values. + +proc ::snit::RT.method.configurelist {type selfns win self optionlist} { + variable ${type}::Snit_optionInfo + + foreach {option value} $optionlist { + # FIRST, get the configure command, caching it if need be. + if {[catch {set ${selfns}::Snit_configureCache($option)} command]} { + set command [snit::RT.CacheConfigureCommand \ + $type $selfns $win $self $option] + + if {[llength $command] == 0} { + return -code error "unknown option \"$option\"" + } + } + + # NEXT, if we have a type-validation object, use it. + # TBD: Should test (islocal-$option) here, but islocal + # isn't defined for implicitly delegated options. + if {[info exists Snit_optionInfo(typeobj-$option)] + && "" != $Snit_optionInfo(typeobj-$option)} { + if {[catch { + $Snit_optionInfo(typeobj-$option) validate $value + } result]} { + return -code error "invalid $option value: $result" + } + } + + # NEXT, the caching the configure command also cached the + # validate command, if any. If we have one, run it. + set valcommand [set ${selfns}::Snit_validateCache($option)] + + if {[llength $valcommand]} { + lappend valcommand $value + uplevel 1 $valcommand + } + + # NEXT, configure the option with the value. + lappend command $value + uplevel 1 $command + } + + return +} + +# Retrieves and caches the command that stores the named option. +# Also stores the command that validates the name option if any; +# If none, the validate command is "", so that the cache is always +# populated. +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name +# option An option name + +proc ::snit::RT.CacheConfigureCommand {type selfns win self option} { + variable ${type}::Snit_optionInfo + variable ${selfns}::Snit_configureCache + variable ${selfns}::Snit_validateCache + + if {[info exist Snit_optionInfo(islocal-$option)]} { + # We know the item; it's either local, or explicitly delegated. + + if {$Snit_optionInfo(islocal-$option)} { + # It's a local option. + + # If it's readonly, it throws an error if we're already + # constructed. + if {$Snit_optionInfo(readonly-$option)} { + if {[set ${selfns}::Snit_iinfo(constructed)]} { + error "option $option can only be set at instance creation" + } + } + + # If it has a validate method, cache that for later. + if {"" != $Snit_optionInfo(validate-$option)} { + set command [snit::RT.LookupMethodCommand \ + $type $selfns $win $self \ + $Snit_optionInfo(validate-$option) \ + "can't validate $option"] + + lappend command $option + set Snit_validateCache($option) $command + } else { + set Snit_validateCache($option) "" + } + + # If it has a configure method defined, + # cache it; otherwise, just set the value. + + if {"" == $Snit_optionInfo(configure-$option)} { + set command [list set ${selfns}::options($option)] + } else { + set command [snit::RT.LookupMethodCommand \ + $type $selfns $win $self \ + $Snit_optionInfo(configure-$option) \ + "can't configure $option"] + + lappend command $option + } + + set Snit_configureCache($option) $command + return $command + } + + # Delegated option: get target. + set comp [lindex $Snit_optionInfo(target-$option) 0] + set target [lindex $Snit_optionInfo(target-$option) 1] + } elseif {$Snit_optionInfo(starcomp) != "" && + [lsearch -exact $Snit_optionInfo(except) $option] == -1} { + # Unknown option, but unknowns are delegated. + set comp $Snit_optionInfo(starcomp) + set target $option + } else { + return "" + } + + # There is no validate command in this case; save an empty string. + set Snit_validateCache($option) "" + + # Get the component's object + set obj [RT.Component $type $selfns $comp] + + set command [list $obj configure $target] + set Snit_configureCache($option) $command + + return $command +} + +# Implements the standard "configure" method +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name +# args A list of options and their values, possibly empty. + +proc ::snit::RT.method.configure {type selfns win self args} { + # If two or more arguments, set values as usual. + if {[llength $args] >= 2} { + ::snit::RT.method.configurelist $type $selfns $win $self $args + return + } + + # If zero arguments, acquire data for each known option + # and return the list + if {[llength $args] == 0} { + set result {} + foreach opt [RT.method.info.options $type $selfns $win $self] { + # Refactor this, so that we don't need to call via $self. + lappend result [RT.GetOptionDbSpec \ + $type $selfns $win $self $opt] + } + + return $result + } + + # They want it for just one. + set opt [lindex $args 0] + + return [RT.GetOptionDbSpec $type $selfns $win $self $opt] +} + + +# Retrieves the option database spec for a single option. +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name +# option The name of an option +# +# TBD: This is a bad name. What it's returning is the +# result of the configure query. + +proc ::snit::RT.GetOptionDbSpec {type selfns win self opt} { + variable ${type}::Snit_optionInfo + + upvar ${selfns}::Snit_components Snit_components + upvar ${selfns}::options options + + if {[info exists options($opt)]} { + # This is a locally-defined option. Just build the + # list and return it. + set res $Snit_optionInfo(resource-$opt) + set cls $Snit_optionInfo(class-$opt) + set def $Snit_optionInfo(default-$opt) + + return [list $opt $res $cls $def \ + [RT.method.cget $type $selfns $win $self $opt]] + } elseif {[info exists Snit_optionInfo(target-$opt)]} { + # This is an explicitly delegated option. The only + # thing we don't have is the default. + set res $Snit_optionInfo(resource-$opt) + set cls $Snit_optionInfo(class-$opt) + + # Get the default + set logicalName [lindex $Snit_optionInfo(target-$opt) 0] + set comp $Snit_components($logicalName) + set target [lindex $Snit_optionInfo(target-$opt) 1] + + if {[catch {$comp configure $target} result]} { + set defValue {} + } else { + set defValue [lindex $result 3] + } + + return [list $opt $res $cls $defValue [$self cget $opt]] + } elseif {"" != $Snit_optionInfo(starcomp) && + [lsearch -exact $Snit_optionInfo(except) $opt] == -1} { + set logicalName $Snit_optionInfo(starcomp) + set target $opt + set comp $Snit_components($logicalName) + + if {[catch {set value [$comp cget $target]} result]} { + error "unknown option \"$opt\"" + } + + if {![catch {$comp configure $target} result]} { + # Replace the delegated option name with the local name. + return [::snit::Expand $result $target $opt] + } + + # configure didn't work; return simple form. + return [list $opt "" "" "" $value] + } else { + error "unknown option \"$opt\"" + } +} + +#----------------------------------------------------------------------- +# Type Introspection + +# Implements the standard "info" typemethod. +# +# type The snit type +# command The info subcommand +# args All other arguments. + +proc ::snit::RT.typemethod.info {type command args} { + global errorInfo + global errorCode + + switch -exact $command { + args - + body - + default - + typevars - + typemethods - + instances { + # TBD: it should be possible to delete this error + # handling. + set errflag [catch { + uplevel 1 [linsert $args 0 \ + ::snit::RT.typemethod.info.$command $type] + } result] + + if {$errflag} { + return -code error -errorinfo $errorInfo \ + -errorcode $errorCode $result + } else { + return $result + } + } + default { + error "\"$type info $command\" is not defined" + } + } +} + + +# Returns a list of the type's typevariables whose names match a +# pattern, excluding Snit internal variables. +# +# type A Snit type +# pattern Optional. The glob pattern to match. Defaults +# to *. + +proc ::snit::RT.typemethod.info.typevars {type {pattern *}} { + set result {} + foreach name [info vars "${type}::$pattern"] { + set tail [namespace tail $name] + if {![string match "Snit_*" $tail]} { + lappend result $name + } + } + + return $result +} + +# Returns a list of the type's methods whose names match a +# pattern. If "delegate typemethod *" is used, the list may +# not be complete. +# +# type A Snit type +# pattern Optional. The glob pattern to match. Defaults +# to *. + +proc ::snit::RT.typemethod.info.typemethods {type {pattern *}} { + variable ${type}::Snit_typemethodInfo + variable ${type}::Snit_typemethodCache + + # FIRST, get the explicit names, skipping prefixes. + set result {} + + foreach name [array names Snit_typemethodInfo $pattern] { + if {[lindex $Snit_typemethodInfo($name) 0] != 1} { + lappend result $name + } + } + + # NEXT, add any from the cache that aren't explicit. + if {[info exists Snit_typemethodInfo(*)]} { + # First, remove "*" from the list. + set ndx [lsearch -exact $result "*"] + if {$ndx != -1} { + set result [lreplace $result $ndx $ndx] + } + + foreach name [array names Snit_typemethodCache $pattern] { + if {[lsearch -exact $result $name] == -1} { + lappend result $name + } + } + } + + return $result +} + +# $type info args +# +# Returns a method's list of arguments. does not work for delegated +# methods, nor for the internal dispatch methods of multi-word +# methods. + +proc ::snit::RT.typemethod.info.args {type method} { + upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo + + # Snit_methodInfo: method -> list (flag cmd component) + + # flag : 1 -> internal dispatcher for multi-word method. + # 0 -> regular method + # + # cmd : template mapping from method to command prefix, may + # contain placeholders for various pieces of information. + # + # component : is empty for normal methods. + + #parray Snit_typemethodInfo + + if {![info exists Snit_typemethodInfo($method)]} { + return -code error "Unknown typemethod \"$method\"" + } + foreach {flag cmd component} $Snit_typemethodInfo($method) break + if {$flag} { + return -code error "Unknown typemethod \"$method\"" + } + if {$component != ""} { + return -code error "Delegated typemethod \"$method\"" + } + + set map [list %m $method %j [join $method _] %t $type] + set theproc [lindex [string map $map $cmd] 0] + return [lrange [::info args $theproc] 1 end] +} + +# $type info body +# +# Returns a method's body. does not work for delegated +# methods, nor for the internal dispatch methods of multi-word +# methods. + +proc ::snit::RT.typemethod.info.body {type method} { + upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo + + # Snit_methodInfo: method -> list (flag cmd component) + + # flag : 1 -> internal dispatcher for multi-word method. + # 0 -> regular method + # + # cmd : template mapping from method to command prefix, may + # contain placeholders for various pieces of information. + # + # component : is empty for normal methods. + + #parray Snit_typemethodInfo + + if {![info exists Snit_typemethodInfo($method)]} { + return -code error "Unknown typemethod \"$method\"" + } + foreach {flag cmd component} $Snit_typemethodInfo($method) break + if {$flag} { + return -code error "Unknown typemethod \"$method\"" + } + if {$component != ""} { + return -code error "Delegated typemethod \"$method\"" + } + + set map [list %m $method %j [join $method _] %t $type] + set theproc [lindex [string map $map $cmd] 0] + return [RT.body [::info body $theproc]] +} + +# $type info default +# +# Returns a method's list of arguments. does not work for delegated +# methods, nor for the internal dispatch methods of multi-word +# methods. + +proc ::snit::RT.typemethod.info.default {type method aname dvar} { + upvar 1 $dvar def + upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo + + # Snit_methodInfo: method -> list (flag cmd component) + + # flag : 1 -> internal dispatcher for multi-word method. + # 0 -> regular method + # + # cmd : template mapping from method to command prefix, may + # contain placeholders for various pieces of information. + # + # component : is empty for normal methods. + + #parray Snit_methodInfo + + if {![info exists Snit_typemethodInfo($method)]} { + return -code error "Unknown typemethod \"$method\"" + } + foreach {flag cmd component} $Snit_typemethodInfo($method) break + if {$flag} { + return -code error "Unknown typemethod \"$method\"" + } + if {$component != ""} { + return -code error "Delegated typemethod \"$method\"" + } + + set map [list %m $method %j [join $method _] %t $type] + set theproc [lindex [string map $map $cmd] 0] + return [::info default $theproc $aname def] +} + +# Returns a list of the type's instances whose names match +# a pattern. +# +# type A Snit type +# pattern Optional. The glob pattern to match +# Defaults to * +# +# REQUIRE: type is fully qualified. + +proc ::snit::RT.typemethod.info.instances {type {pattern *}} { + set result {} + + foreach selfns [namespace children $type "${type}::Snit_inst*"] { + upvar ${selfns}::Snit_instance instance + + if {[string match $pattern $instance]} { + lappend result $instance + } + } + + return $result +} + +#----------------------------------------------------------------------- +# Instance Introspection + +# Implements the standard "info" method. +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name +# command The info subcommand +# args All other arguments. + +proc ::snit::RT.method.info {type selfns win self command args} { + switch -exact $command { + args - + body - + default - + type - + vars - + options - + methods - + typevars - + typemethods { + set errflag [catch { + uplevel 1 [linsert $args 0 ::snit::RT.method.info.$command \ + $type $selfns $win $self] + } result] + + if {$errflag} { + global errorInfo + return -code error -errorinfo $errorInfo $result + } else { + return $result + } + } + default { + # error "\"$self info $command\" is not defined" + return -code error "\"$self info $command\" is not defined" + } + } +} + +# $self info type +# +# Returns the instance's type +proc ::snit::RT.method.info.type {type selfns win self} { + return $type +} + +# $self info typevars +# +# Returns the instance's type's typevariables +proc ::snit::RT.method.info.typevars {type selfns win self {pattern *}} { + return [RT.typemethod.info.typevars $type $pattern] +} + +# $self info typemethods +# +# Returns the instance's type's typemethods +proc ::snit::RT.method.info.typemethods {type selfns win self {pattern *}} { + return [RT.typemethod.info.typemethods $type $pattern] +} + +# Returns a list of the instance's methods whose names match a +# pattern. If "delegate method *" is used, the list may +# not be complete. +# +# type A Snit type +# selfns The instance namespace +# win The original instance name +# self The current instance name +# pattern Optional. The glob pattern to match. Defaults +# to *. + +proc ::snit::RT.method.info.methods {type selfns win self {pattern *}} { + variable ${type}::Snit_methodInfo + variable ${selfns}::Snit_methodCache + + # FIRST, get the explicit names, skipping prefixes. + set result {} + + foreach name [array names Snit_methodInfo $pattern] { + if {[lindex $Snit_methodInfo($name) 0] != 1} { + lappend result $name + } + } + + # NEXT, add any from the cache that aren't explicit. + if {[info exists Snit_methodInfo(*)]} { + # First, remove "*" from the list. + set ndx [lsearch -exact $result "*"] + if {$ndx != -1} { + set result [lreplace $result $ndx $ndx] + } + + foreach name [array names Snit_methodCache $pattern] { + if {[lsearch -exact $result $name] == -1} { + lappend result $name + } + } + } + + return $result +} + +# $self info args +# +# Returns a method's list of arguments. does not work for delegated +# methods, nor for the internal dispatch methods of multi-word +# methods. + +proc ::snit::RT.method.info.args {type selfns win self method} { + + upvar ${type}::Snit_methodInfo Snit_methodInfo + + # Snit_methodInfo: method -> list (flag cmd component) + + # flag : 1 -> internal dispatcher for multi-word method. + # 0 -> regular method + # + # cmd : template mapping from method to command prefix, may + # contain placeholders for various pieces of information. + # + # component : is empty for normal methods. + + #parray Snit_methodInfo + + if {![info exists Snit_methodInfo($method)]} { + return -code error "Unknown method \"$method\"" + } + foreach {flag cmd component} $Snit_methodInfo($method) break + if {$flag} { + return -code error "Unknown method \"$method\"" + } + if {$component != ""} { + return -code error "Delegated method \"$method\"" + } + + set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self] + set theproc [lindex [string map $map $cmd] 0] + return [lrange [::info args $theproc] 4 end] +} + +# $self info body +# +# Returns a method's body. does not work for delegated +# methods, nor for the internal dispatch methods of multi-word +# methods. + +proc ::snit::RT.method.info.body {type selfns win self method} { + + upvar ${type}::Snit_methodInfo Snit_methodInfo + + # Snit_methodInfo: method -> list (flag cmd component) + + # flag : 1 -> internal dispatcher for multi-word method. + # 0 -> regular method + # + # cmd : template mapping from method to command prefix, may + # contain placeholders for various pieces of information. + # + # component : is empty for normal methods. + + #parray Snit_methodInfo + + if {![info exists Snit_methodInfo($method)]} { + return -code error "Unknown method \"$method\"" + } + foreach {flag cmd component} $Snit_methodInfo($method) break + if {$flag} { + return -code error "Unknown method \"$method\"" + } + if {$component != ""} { + return -code error "Delegated method \"$method\"" + } + + set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self] + set theproc [lindex [string map $map $cmd] 0] + return [RT.body [::info body $theproc]] +} + +# $self info default +# +# Returns a method's list of arguments. does not work for delegated +# methods, nor for the internal dispatch methods of multi-word +# methods. + +proc ::snit::RT.method.info.default {type selfns win self method aname dvar} { + upvar 1 $dvar def + upvar ${type}::Snit_methodInfo Snit_methodInfo + + # Snit_methodInfo: method -> list (flag cmd component) + + # flag : 1 -> internal dispatcher for multi-word method. + # 0 -> regular method + # + # cmd : template mapping from method to command prefix, may + # contain placeholders for various pieces of information. + # + # component : is empty for normal methods. + + if {![info exists Snit_methodInfo($method)]} { + return -code error "Unknown method \"$method\"" + } + foreach {flag cmd component} $Snit_methodInfo($method) break + if {$flag} { + return -code error "Unknown method \"$method\"" + } + if {$component != ""} { + return -code error "Delegated method \"$method\"" + } + + set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self] + set theproc [lindex [string map $map $cmd] 0] + return [::info default $theproc $aname def] +} + +# $self info vars +# +# Returns the instance's instance variables +proc ::snit::RT.method.info.vars {type selfns win self {pattern *}} { + set result {} + foreach name [info vars "${selfns}::$pattern"] { + set tail [namespace tail $name] + if {![string match "Snit_*" $tail]} { + lappend result $name + } + } + + return $result +} + +# $self info options +# +# Returns a list of the names of the instance's options +proc ::snit::RT.method.info.options {type selfns win self {pattern *}} { + variable ${type}::Snit_optionInfo + + # First, get the local and explicitly delegated options + set result [concat $Snit_optionInfo(local) $Snit_optionInfo(delegated)] + + # If "configure" works as for Tk widgets, add the resulting + # options to the list. Skip excepted options + if {"" != $Snit_optionInfo(starcomp)} { + upvar ${selfns}::Snit_components Snit_components + set logicalName $Snit_optionInfo(starcomp) + set comp $Snit_components($logicalName) + + if {![catch {$comp configure} records]} { + foreach record $records { + set opt [lindex $record 0] + if {[lsearch -exact $result $opt] == -1 && + [lsearch -exact $Snit_optionInfo(except) $opt] == -1} { + lappend result $opt + } + } + } + } + + # Next, apply the pattern + set names {} + + foreach name $result { + if {[string match $pattern $name]} { + lappend names $name + } + } + + return $names +} + +proc ::snit::RT.body {body} { + regsub -all ".*# END snit method prolog\n" $body {} body + return $body +} diff --git a/src/bootsupport/lib/snit/main2.tcl b/src/bootsupport/lib/snit/main2.tcl new file mode 100644 index 00000000..24563938 --- /dev/null +++ b/src/bootsupport/lib/snit/main2.tcl @@ -0,0 +1,3888 @@ +#----------------------------------------------------------------------- +# TITLE: +# main2.tcl +# +# AUTHOR: +# Will Duquette +# +# DESCRIPTION: +# Snit's Not Incr Tcl, a simple object system in Pure Tcl. +# +# Snit 2.x Compiler and Run-Time Library +# +# Copyright (C) 2003-2006 by William H. Duquette +# This code is licensed as described in license.txt. +# +#----------------------------------------------------------------------- + +#----------------------------------------------------------------------- +# Namespace + +namespace eval ::snit:: { + namespace export \ + compile type widget widgetadaptor typemethod method macro +} + +#----------------------------------------------------------------------- +# Some Snit variables + +namespace eval ::snit:: { + variable reservedArgs {type selfns win self} + + # Widget classes which can be hulls (must have -class) + variable hulltypes { + toplevel tk::toplevel + frame tk::frame ttk::frame + labelframe tk::labelframe ttk::labelframe + } +} + +#----------------------------------------------------------------------- +# Snit Type Implementation template + +namespace eval ::snit:: { + # Template type definition: All internal and user-visible Snit + # implementation code. + # + # The following placeholders will automatically be replaced with + # the client's code, in two passes: + # + # First pass: + # %COMPILEDDEFS% The compiled type definition. + # + # Second pass: + # %TYPE% The fully qualified type name. + # %IVARDECS% Instance variable declarations + # %TVARDECS% Type variable declarations + # %TCONSTBODY% Type constructor body + # %INSTANCEVARS% The compiled instance variable initialization code. + # %TYPEVARS% The compiled type variable initialization code. + + # This is the overall type template. + variable typeTemplate + + # This is the normal type proc + variable nominalTypeProc + + # This is the "-hastypemethods no" type proc + variable simpleTypeProc +} + +set ::snit::typeTemplate { + + #------------------------------------------------------------------- + # The type's namespace definition and the user's type variables + + namespace eval %TYPE% {%TYPEVARS% + } + + #---------------------------------------------------------------- + # Commands for use in methods, typemethods, etc. + # + # These are implemented as aliases into the Snit runtime library. + + interp alias {} %TYPE%::installhull {} ::snit::RT.installhull %TYPE% + interp alias {} %TYPE%::install {} ::snit::RT.install %TYPE% + interp alias {} %TYPE%::typevariable {} ::variable + interp alias {} %TYPE%::variable {} ::snit::RT.variable + interp alias {} %TYPE%::mytypevar {} ::snit::RT.mytypevar %TYPE% + interp alias {} %TYPE%::typevarname {} ::snit::RT.mytypevar %TYPE% + interp alias {} %TYPE%::myvar {} ::snit::RT.myvar + interp alias {} %TYPE%::varname {} ::snit::RT.myvar + interp alias {} %TYPE%::codename {} ::snit::RT.codename %TYPE% + interp alias {} %TYPE%::myproc {} ::snit::RT.myproc %TYPE% + interp alias {} %TYPE%::mymethod {} ::snit::RT.mymethod + interp alias {} %TYPE%::mytypemethod {} ::snit::RT.mytypemethod %TYPE% + interp alias {} %TYPE%::from {} ::snit::RT.from %TYPE% + + #------------------------------------------------------------------- + # Snit's internal variables + + namespace eval %TYPE% { + # Array: General Snit Info + # + # ns: The type's namespace + # hasinstances: T or F, from pragma -hasinstances. + # simpledispatch: T or F, from pragma -hasinstances. + # canreplace: T or F, from pragma -canreplace. + # counter: Count of instances created so far. + # widgetclass: Set by widgetclass statement. + # hulltype: Hull type (frame or toplevel) for widgets only. + # exceptmethods: Methods explicitly not delegated to * + # excepttypemethods: Methods explicitly not delegated to * + # tvardecs: Type variable declarations--for dynamic methods + # ivardecs: Instance variable declarations--for dyn. methods + typevariable Snit_info + set Snit_info(ns) %TYPE%:: + set Snit_info(hasinstances) 1 + set Snit_info(simpledispatch) 0 + set Snit_info(canreplace) 0 + set Snit_info(counter) 0 + set Snit_info(widgetclass) {} + set Snit_info(hulltype) frame + set Snit_info(exceptmethods) {} + set Snit_info(excepttypemethods) {} + set Snit_info(tvardecs) {%TVARDECS%} + set Snit_info(ivardecs) {%IVARDECS%} + + # Array: Public methods of this type. + # The index is the method name, or "*". + # The value is [list $pattern $componentName], where + # $componentName is "" for normal methods. + typevariable Snit_typemethodInfo + array unset Snit_typemethodInfo + + # Array: Public methods of instances of this type. + # The index is the method name, or "*". + # The value is [list $pattern $componentName], where + # $componentName is "" for normal methods. + typevariable Snit_methodInfo + array unset Snit_methodInfo + + # Array: option information. See dictionary.txt. + typevariable Snit_optionInfo + array unset Snit_optionInfo + set Snit_optionInfo(local) {} + set Snit_optionInfo(delegated) {} + set Snit_optionInfo(starcomp) {} + set Snit_optionInfo(except) {} + } + + #---------------------------------------------------------------- + # Compiled Procs + # + # These commands are created or replaced during compilation: + + + # Snit_instanceVars selfns + # + # Initializes the instance variables, if any. Called during + # instance creation. + + proc %TYPE%::Snit_instanceVars {selfns} { + %INSTANCEVARS% + } + + # Type Constructor + proc %TYPE%::Snit_typeconstructor {type} { + %TVARDECS% + namespace path [namespace parent $type] + %TCONSTBODY% + } + + #---------------------------------------------------------------- + # Default Procs + # + # These commands might be replaced during compilation: + + # Snit_destructor type selfns win self + # + # Default destructor for the type. By default, it does + # nothing. It's replaced by any user destructor. + # For types, it's called by method destroy; for widgettypes, + # it's called by a destroy event handler. + + proc %TYPE%::Snit_destructor {type selfns win self} { } + + #---------------------------------------------------------- + # Compiled Definitions + + %COMPILEDDEFS% + + #---------------------------------------------------------- + # Finally, call the Type Constructor + + %TYPE%::Snit_typeconstructor %TYPE% +} + +#----------------------------------------------------------------------- +# Type procs +# +# These procs expect the fully-qualified type name to be +# substituted in for %TYPE%. + +# This is the nominal type proc. It supports typemethods and +# delegated typemethods. +set ::snit::nominalTypeProc { + # WHD: Code for creating the type ensemble + namespace eval %TYPE% { + namespace ensemble create \ + -unknown [list ::snit::RT.UnknownTypemethod %TYPE% ""] \ + -prefixes 0 + } +} + +# This is the simplified type proc for when there are no typemethods +# except create. In this case, it doesn't take a method argument; +# the method is always "create". +set ::snit::simpleTypeProc { + # Type dispatcher function. Note: This function lives + # in the parent of the %TYPE% namespace! All accesses to + # %TYPE% variables and methods must be qualified! + proc %TYPE% {args} { + ::variable %TYPE%::Snit_info + + # FIRST, if the are no args, the single arg is %AUTO% + if {[llength $args] == 0} { + if {$Snit_info(isWidget)} { + error "wrong \# args: should be \"%TYPE% name args\"" + } + + lappend args %AUTO% + } + + # NEXT, we're going to call the create method. + # Pass along the return code unchanged. + if {$Snit_info(isWidget)} { + set command [list ::snit::RT.widget.typemethod.create %TYPE%] + } else { + set command [list ::snit::RT.type.typemethod.create %TYPE%] + } + + set retval [catch {uplevel 1 $command $args} result] + + if {$retval} { + if {$retval == 1} { + global errorInfo + global errorCode + return -code error -errorinfo $errorInfo \ + -errorcode $errorCode $result + } else { + return -code $retval $result + } + } + + return $result + } +} + +#======================================================================= +# Snit Type Definition +# +# These are the procs used to define Snit types, widgets, and +# widgetadaptors. + + +#----------------------------------------------------------------------- +# Snit Compilation Variables +# +# The following variables are used while Snit is compiling a type, +# and are disposed afterwards. + +namespace eval ::snit:: { + # The compiler variable contains the name of the slave interpreter + # used to compile type definitions. + variable compiler "" + + # The compile array accumulates information about the type or + # widgettype being compiled. It is cleared before and after each + # compilation. It has these indices: + # + # type: The name of the type being compiled, for use + # in compilation procs. + # defs: Compiled definitions, both standard and client. + # which: type, widget, widgetadaptor + # instancevars: Instance variable definitions and initializations. + # ivprocdec: Instance variable proc declarations. + # tvprocdec: Type variable proc declarations. + # typeconstructor: Type constructor body. + # widgetclass: The widgetclass, for snit::widgets, only + # hasoptions: False, initially; set to true when first + # option is defined. + # localoptions: Names of local options. + # delegatedoptions: Names of delegated options. + # localmethods: Names of locally defined methods. + # delegatesmethods: no if no delegated methods, yes otherwise. + # hashierarchic : no if no hierarchic methods, yes otherwise. + # components: Names of defined components. + # typecomponents: Names of defined typecomponents. + # typevars: Typevariable definitions and initializations. + # varnames: Names of instance variables + # typevarnames Names of type variables + # hasconstructor False, initially; true when constructor is + # defined. + # resource-$opt The option's resource name + # class-$opt The option's class + # -default-$opt The option's default value + # -validatemethod-$opt The option's validate method + # -configuremethod-$opt The option's configure method + # -cgetmethod-$opt The option's cget method. + # -hastypeinfo The -hastypeinfo pragma + # -hastypedestroy The -hastypedestroy pragma + # -hastypemethods The -hastypemethods pragma + # -hasinfo The -hasinfo pragma + # -hasinstances The -hasinstances pragma + # -simpledispatch The -simpledispatch pragma WHD: OBSOLETE + # -canreplace The -canreplace pragma + variable compile + + # This variable accumulates method dispatch information; it has + # the same structure as the %TYPE%::Snit_methodInfo array, and is + # used to initialize it. + variable methodInfo + + # This variable accumulates typemethod dispatch information; it has + # the same structure as the %TYPE%::Snit_typemethodInfo array, and is + # used to initialize it. + variable typemethodInfo + + # The following variable lists the reserved type definition statement + # names, e.g., the names you can't use as macros. It's built at + # compiler definition time using "info commands". + variable reservedwords {} +} + +#----------------------------------------------------------------------- +# type compilation commands +# +# The type and widgettype commands use a slave interpreter to compile +# the type definition. These are the procs +# that are aliased into it. + +# Initialize the compiler +proc ::snit::Comp.Init {} { + variable compiler + variable reservedwords + + if {$compiler eq ""} { + # Create the compiler's interpreter + set compiler [interp create] + + # Initialize the interpreter + $compiler eval { + catch {close stdout} + catch {close stderr} + catch {close stdin} + + # Load package information + # TBD: see if this can be moved outside. + # @mdgen NODEP: ::snit::__does_not_exist__ + catch {package require ::snit::__does_not_exist__} + + # Protect some Tcl commands our type definitions + # will shadow. + rename proc _proc + rename variable _variable + } + + # Define compilation aliases. + $compiler alias pragma ::snit::Comp.statement.pragma + $compiler alias widgetclass ::snit::Comp.statement.widgetclass + $compiler alias hulltype ::snit::Comp.statement.hulltype + $compiler alias constructor ::snit::Comp.statement.constructor + $compiler alias destructor ::snit::Comp.statement.destructor + $compiler alias option ::snit::Comp.statement.option + $compiler alias oncget ::snit::Comp.statement.oncget + $compiler alias onconfigure ::snit::Comp.statement.onconfigure + $compiler alias method ::snit::Comp.statement.method + $compiler alias typemethod ::snit::Comp.statement.typemethod + $compiler alias typeconstructor ::snit::Comp.statement.typeconstructor + $compiler alias proc ::snit::Comp.statement.proc + $compiler alias typevariable ::snit::Comp.statement.typevariable + $compiler alias variable ::snit::Comp.statement.variable + $compiler alias typecomponent ::snit::Comp.statement.typecomponent + $compiler alias component ::snit::Comp.statement.component + $compiler alias delegate ::snit::Comp.statement.delegate + $compiler alias expose ::snit::Comp.statement.expose + + # Get the list of reserved words + set reservedwords [$compiler eval {info commands}] + } +} + +# Compile a type definition, and return the results as a list of two +# items: the fully-qualified type name, and a script that will define +# the type when executed. +# +# which type, widget, or widgetadaptor +# type the type name +# body the type definition +proc ::snit::Comp.Compile {which type body} { + variable typeTemplate + variable nominalTypeProc + variable simpleTypeProc + variable compile + variable compiler + variable methodInfo + variable typemethodInfo + + # FIRST, qualify the name. + if {![string match "::*" $type]} { + # Get caller's namespace; + # append :: if not global namespace. + set ns [uplevel 2 [list namespace current]] + if {"::" != $ns} { + append ns "::" + } + + set type "$ns$type" + } + + # NEXT, create and initialize the compiler, if needed. + Comp.Init + + # NEXT, initialize the class data + array unset methodInfo + array unset typemethodInfo + + array unset compile + set compile(type) $type + set compile(defs) {} + set compile(which) $which + set compile(hasoptions) no + set compile(localoptions) {} + set compile(instancevars) {} + set compile(typevars) {} + set compile(delegatedoptions) {} + set compile(ivprocdec) {} + set compile(tvprocdec) {} + set compile(typeconstructor) {} + set compile(widgetclass) {} + set compile(hulltype) {} + set compile(localmethods) {} + set compile(delegatesmethods) no + set compile(hashierarchic) no + set compile(components) {} + set compile(typecomponents) {} + set compile(varnames) {} + set compile(typevarnames) {} + set compile(hasconstructor) no + set compile(-hastypedestroy) yes + set compile(-hastypeinfo) yes + set compile(-hastypemethods) yes + set compile(-hasinfo) yes + set compile(-hasinstances) yes + set compile(-canreplace) no + + set isWidget [string match widget* $which] + set isWidgetAdaptor [string match widgetadaptor $which] + + # NEXT, Evaluate the type's definition in the class interpreter. + $compiler eval $body + + # NEXT, Add the standard definitions + append compile(defs) \ + "\nset %TYPE%::Snit_info(isWidget) $isWidget\n" + + append compile(defs) \ + "\nset %TYPE%::Snit_info(isWidgetAdaptor) $isWidgetAdaptor\n" + + # Indicate whether the type can create instances that replace + # existing commands. + append compile(defs) "\nset %TYPE%::Snit_info(canreplace) $compile(-canreplace)\n" + + + # Check pragmas for conflict. + + if {!$compile(-hastypemethods) && !$compile(-hasinstances)} { + error "$which $type has neither typemethods nor instances" + } + + # If there are typemethods, define the standard typemethods and + # the nominal type proc. Otherwise define the simple type proc. + if {$compile(-hastypemethods)} { + # Add the info typemethod unless the pragma forbids it. + if {$compile(-hastypeinfo)} { + Comp.statement.delegate typemethod info \ + using {::snit::RT.typemethod.info %t} + } + + # Add the destroy typemethod unless the pragma forbids it. + if {$compile(-hastypedestroy)} { + Comp.statement.delegate typemethod destroy \ + using {::snit::RT.typemethod.destroy %t} + } + + # Add the nominal type proc. + append compile(defs) $nominalTypeProc + } else { + # Add the simple type proc. + append compile(defs) $simpleTypeProc + } + + # Add standard methods/typemethods that only make sense if the + # type has instances. + if {$compile(-hasinstances)} { + # Add the info method unless the pragma forbids it. + if {$compile(-hasinfo)} { + Comp.statement.delegate method info \ + using {::snit::RT.method.info %t %n %w %s} + } + + # Add the option handling stuff if there are any options. + if {$compile(hasoptions)} { + Comp.statement.variable options + + Comp.statement.delegate method cget \ + using {::snit::RT.method.cget %t %n %w %s} + Comp.statement.delegate method configurelist \ + using {::snit::RT.method.configurelist %t %n %w %s} + Comp.statement.delegate method configure \ + using {::snit::RT.method.configure %t %n %w %s} + } + + # Add a default constructor, if they haven't already defined one. + # If there are options, it will configure args; otherwise it + # will do nothing. + if {!$compile(hasconstructor)} { + if {$compile(hasoptions)} { + Comp.statement.constructor {args} { + $self configurelist $args + } + } else { + Comp.statement.constructor {} {} + } + } + + if {!$isWidget} { + Comp.statement.delegate method destroy \ + using {::snit::RT.method.destroy %t %n %w %s} + + Comp.statement.delegate typemethod create \ + using {::snit::RT.type.typemethod.create %t} + } else { + Comp.statement.delegate typemethod create \ + using {::snit::RT.widget.typemethod.create %t} + } + + # Save the method info. + append compile(defs) \ + "\narray set %TYPE%::Snit_methodInfo [list [array get methodInfo]]\n" + } else { + append compile(defs) "\nset %TYPE%::Snit_info(hasinstances) 0\n" + } + + # NEXT, compiling the type definition built up a set of information + # about the type's locally defined options; add this information to + # the compiled definition. + Comp.SaveOptionInfo + + # NEXT, compiling the type definition built up a set of information + # about the typemethods; save the typemethod info. + append compile(defs) \ + "\narray set %TYPE%::Snit_typemethodInfo [list [array get typemethodInfo]]\n" + + # NEXT, if this is a widget define the hull component if it isn't + # already defined. + if {$isWidget} { + Comp.DefineComponent hull + } + + # NEXT, substitute the compiled definition into the type template + # to get the type definition script. + set defscript [Expand $typeTemplate \ + %COMPILEDDEFS% $compile(defs)] + + # NEXT, substitute the defined macros into the type definition script. + # This is done as a separate step so that the compile(defs) can + # contain the macros defined below. + + set defscript [Expand $defscript \ + %TYPE% $type \ + %IVARDECS% $compile(ivprocdec) \ + %TVARDECS% $compile(tvprocdec) \ + %TCONSTBODY% $compile(typeconstructor) \ + %INSTANCEVARS% $compile(instancevars) \ + %TYPEVARS% $compile(typevars) \ + ] + + array unset compile + + return [list $type $defscript] +} + +# Information about locally-defined options is accumulated during +# compilation, but not added to the compiled definition--the option +# statement can appear multiple times, so it's easier this way. +# This proc fills in Snit_optionInfo with the accumulated information. +# +# It also computes the option's resource and class names if needed. +# +# Note that the information for delegated options was put in +# Snit_optionInfo during compilation. + +proc ::snit::Comp.SaveOptionInfo {} { + variable compile + + foreach option $compile(localoptions) { + if {$compile(resource-$option) eq ""} { + set compile(resource-$option) [string range $option 1 end] + } + + if {$compile(class-$option) eq ""} { + set compile(class-$option) [Capitalize $compile(resource-$option)] + } + + # NOTE: Don't verify that the validate, configure, and cget + # values name real methods; the methods might be defined outside + # the typedefinition using snit::method. + + Mappend compile(defs) { + # Option %OPTION% + lappend %TYPE%::Snit_optionInfo(local) %OPTION% + + set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 1 + set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RESOURCE% + set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS% + set %TYPE%::Snit_optionInfo(default-%OPTION%) %DEFAULT% + set %TYPE%::Snit_optionInfo(validate-%OPTION%) %VALIDATE% + set %TYPE%::Snit_optionInfo(configure-%OPTION%) %CONFIGURE% + set %TYPE%::Snit_optionInfo(cget-%OPTION%) %CGET% + set %TYPE%::Snit_optionInfo(readonly-%OPTION%) %READONLY% + set %TYPE%::Snit_optionInfo(typespec-%OPTION%) %TYPESPEC% + } %OPTION% $option \ + %RESOURCE% $compile(resource-$option) \ + %CLASS% $compile(class-$option) \ + %DEFAULT% [list $compile(-default-$option)] \ + %VALIDATE% [list $compile(-validatemethod-$option)] \ + %CONFIGURE% [list $compile(-configuremethod-$option)] \ + %CGET% [list $compile(-cgetmethod-$option)] \ + %READONLY% $compile(-readonly-$option) \ + %TYPESPEC% [list $compile(-type-$option)] + } +} + + +# Evaluates a compiled type definition, thus making the type available. +proc ::snit::Comp.Define {compResult} { + # The compilation result is a list containing the fully qualified + # type name and a script to evaluate to define the type. + set type [lindex $compResult 0] + set defscript [lindex $compResult 1] + + # Execute the type definition script. + # Consider using namespace eval %TYPE%. See if it's faster. + if {[catch {eval $defscript} result]} { + namespace delete $type + catch {rename $type ""} + error $result + } + + return $type +} + +# Sets pragma options which control how the type is defined. +proc ::snit::Comp.statement.pragma {args} { + variable compile + + set errRoot "Error in \"pragma...\"" + + foreach {opt val} $args { + switch -exact -- $opt { + -hastypeinfo - + -hastypedestroy - + -hastypemethods - + -hasinstances - + -simpledispatch - + -hasinfo - + -canreplace { + if {![string is boolean -strict $val]} { + error "$errRoot, \"$opt\" requires a boolean value" + } + set compile($opt) $val + } + default { + error "$errRoot, unknown pragma" + } + } + } +} + +# Defines a widget's option class name. +# This statement is only available for snit::widgets, +# not for snit::types or snit::widgetadaptors. +proc ::snit::Comp.statement.widgetclass {name} { + variable compile + + # First, widgetclass can only be set for true widgets + if {"widget" != $compile(which)} { + error "widgetclass cannot be set for snit::$compile(which)s" + } + + # Next, validate the option name. We'll require that it begin + # with an uppercase letter. + set initial [string index $name 0] + if {![string is upper $initial]} { + error "widgetclass \"$name\" does not begin with an uppercase letter" + } + + if {"" != $compile(widgetclass)} { + error "too many widgetclass statements" + } + + # Next, save it. + Mappend compile(defs) { + set %TYPE%::Snit_info(widgetclass) %WIDGETCLASS% + } %WIDGETCLASS% [list $name] + + set compile(widgetclass) $name +} + +# Defines a widget's hull type. +# This statement is only available for snit::widgets, +# not for snit::types or snit::widgetadaptors. +proc ::snit::Comp.statement.hulltype {name} { + variable compile + variable hulltypes + + # First, hulltype can only be set for true widgets + if {"widget" != $compile(which)} { + error "hulltype cannot be set for snit::$compile(which)s" + } + + # Next, it must be one of the valid hulltypes (frame, toplevel, ...) + if {[lsearch -exact $hulltypes [string trimleft $name :]] == -1} { + error "invalid hulltype \"$name\", should be one of\ + [join $hulltypes {, }]" + } + + if {"" != $compile(hulltype)} { + error "too many hulltype statements" + } + + # Next, save it. + Mappend compile(defs) { + set %TYPE%::Snit_info(hulltype) %HULLTYPE% + } %HULLTYPE% $name + + set compile(hulltype) $name +} + +# Defines a constructor. +proc ::snit::Comp.statement.constructor {arglist body} { + variable compile + + CheckArgs "constructor" $arglist + + # Next, add a magic reference to self. + set arglist [concat type selfns win self $arglist] + + # Next, add variable declarations to body: + set body "%TVARDECS%\n%IVARDECS%\n$body" + + set compile(hasconstructor) yes + append compile(defs) "proc %TYPE%::Snit_constructor [list $arglist] [list $body]\n" +} + +# Defines a destructor. +proc ::snit::Comp.statement.destructor {body} { + variable compile + + # Next, add variable declarations to body: + set body "%TVARDECS%\n%IVARDECS%\n$body" + + append compile(defs) "proc %TYPE%::Snit_destructor {type selfns win self} [list $body]\n\n" +} + +# Defines a type option. The option value can be a triple, specifying +# the option's -name, resource name, and class name. +proc ::snit::Comp.statement.option {optionDef args} { + variable compile + + # First, get the three option names. + set option [lindex $optionDef 0] + set resourceName [lindex $optionDef 1] + set className [lindex $optionDef 2] + + set errRoot "Error in \"option [list $optionDef]...\"" + + # Next, validate the option name. + if {![Comp.OptionNameIsValid $option]} { + error "$errRoot, badly named option \"$option\"" + } + + if {$option in $compile(delegatedoptions)} { + error "$errRoot, cannot define \"$option\" locally, it has been delegated" + } + + if {!($option in $compile(localoptions))} { + # Remember that we've seen this one. + set compile(hasoptions) yes + lappend compile(localoptions) $option + + # Initialize compilation info for this option. + set compile(resource-$option) "" + set compile(class-$option) "" + set compile(-default-$option) "" + set compile(-validatemethod-$option) "" + set compile(-configuremethod-$option) "" + set compile(-cgetmethod-$option) "" + set compile(-readonly-$option) 0 + set compile(-type-$option) "" + } + + # NEXT, see if we have a resource name. If so, make sure it + # isn't being redefined differently. + if {$resourceName ne ""} { + if {$compile(resource-$option) eq ""} { + # If it's undefined, just save the value. + set compile(resource-$option) $resourceName + } elseif {$resourceName ne $compile(resource-$option)} { + # It's been redefined differently. + error "$errRoot, resource name redefined from \"$compile(resource-$option)\" to \"$resourceName\"" + } + } + + # NEXT, see if we have a class name. If so, make sure it + # isn't being redefined differently. + if {$className ne ""} { + if {$compile(class-$option) eq ""} { + # If it's undefined, just save the value. + set compile(class-$option) $className + } elseif {$className ne $compile(class-$option)} { + # It's been redefined differently. + error "$errRoot, class name redefined from \"$compile(class-$option)\" to \"$className\"" + } + } + + # NEXT, handle the args; it's not an error to redefine these. + if {[llength $args] == 1} { + set compile(-default-$option) [lindex $args 0] + } else { + foreach {optopt val} $args { + switch -exact -- $optopt { + -default - + -validatemethod - + -configuremethod - + -cgetmethod { + set compile($optopt-$option) $val + } + -type { + set compile($optopt-$option) $val + + if {[llength $val] == 1} { + # The type spec *is* the validation object + append compile(defs) \ + "\nset %TYPE%::Snit_optionInfo(typeobj-$option) [list $val]\n" + } else { + # Compilation the creation of the validation object + set cmd [linsert $val 1 %TYPE%::Snit_TypeObj_%AUTO%] + append compile(defs) \ + "\nset %TYPE%::Snit_optionInfo(typeobj-$option) \[$cmd\]\n" + } + } + -readonly { + if {![string is boolean -strict $val]} { + error "$errRoot, -readonly requires a boolean, got \"$val\"" + } + set compile($optopt-$option) $val + } + default { + error "$errRoot, unknown option definition option \"$optopt\"" + } + } + } + } +} + +# 1 if the option name is valid, 0 otherwise. +proc ::snit::Comp.OptionNameIsValid {option} { + if {![string match {-*} $option] || [string match {*[A-Z ]*} $option]} { + return 0 + } + + return 1 +} + +# Defines an option's cget handler +proc ::snit::Comp.statement.oncget {option body} { + variable compile + + set errRoot "Error in \"oncget $option...\"" + + if {[lsearch -exact $compile(delegatedoptions) $option] != -1} { + return -code error "$errRoot, option \"$option\" is delegated" + } + + if {[lsearch -exact $compile(localoptions) $option] == -1} { + return -code error "$errRoot, option \"$option\" unknown" + } + + Comp.statement.method _cget$option {_option} $body + Comp.statement.option $option -cgetmethod _cget$option +} + +# Defines an option's configure handler. +proc ::snit::Comp.statement.onconfigure {option arglist body} { + variable compile + + if {[lsearch -exact $compile(delegatedoptions) $option] != -1} { + return -code error "onconfigure $option: option \"$option\" is delegated" + } + + if {[lsearch -exact $compile(localoptions) $option] == -1} { + return -code error "onconfigure $option: option \"$option\" unknown" + } + + if {[llength $arglist] != 1} { + error \ + "onconfigure $option handler should have one argument, got \"$arglist\"" + } + + CheckArgs "onconfigure $option" $arglist + + # Next, add a magic reference to the option name + set arglist [concat _option $arglist] + + Comp.statement.method _configure$option $arglist $body + Comp.statement.option $option -configuremethod _configure$option +} + +# Defines an instance method. +proc ::snit::Comp.statement.method {method arglist body} { + variable compile + variable methodInfo + + # FIRST, check the method name against previously defined + # methods. + Comp.CheckMethodName $method 0 ::snit::methodInfo \ + "Error in \"method [list $method]...\"" + + if {[llength $method] > 1} { + set compile(hashierarchic) yes + } + + # Remeber this method + lappend compile(localmethods) $method + + CheckArgs "method [list $method]" $arglist + + # Next, add magic references to type and self. + set arglist [concat type selfns win self $arglist] + + # Next, add variable declarations to body: + set body "%TVARDECS%\n%IVARDECS%\n# END snit method prolog\n$body" + + # Next, save the definition script. + if {[llength $method] == 1} { + set methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""} + Mappend compile(defs) { + proc %TYPE%::Snit_method%METHOD% %ARGLIST% %BODY% + } %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body] + } else { + set methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""} + + Mappend compile(defs) { + proc %TYPE%::Snit_hmethod%JMETHOD% %ARGLIST% %BODY% + } %JMETHOD% [join $method _] %ARGLIST% [list $arglist] \ + %BODY% [list $body] + } +} + +# Check for name collisions; save prefix information. +# +# method The name of the method or typemethod. +# delFlag 1 if delegated, 0 otherwise. +# infoVar The fully qualified name of the array containing +# information about the defined methods. +# errRoot The root string for any error messages. + +proc ::snit::Comp.CheckMethodName {method delFlag infoVar errRoot} { + upvar $infoVar methodInfo + + # FIRST, make sure the method name is a valid Tcl list. + if {[catch {lindex $method 0}]} { + error "$errRoot, the name \"$method\" must have list syntax." + } + + # NEXT, check whether we can define it. + if {![catch {set methodInfo($method)} data]} { + # We can't redefine methods with submethods. + if {[lindex $data 0] == 1} { + error "$errRoot, \"$method\" has submethods." + } + + # You can't delegate a method that's defined locally, + # and you can't define a method locally if it's been delegated. + if {$delFlag && [lindex $data 2] eq ""} { + error "$errRoot, \"$method\" has been defined locally." + } elseif {!$delFlag && [lindex $data 2] ne ""} { + error "$errRoot, \"$method\" has been delegated" + } + } + + # Handle hierarchical case. + if {[llength $method] > 1} { + set prefix {} + set tokens $method + while {[llength $tokens] > 1} { + lappend prefix [lindex $tokens 0] + set tokens [lrange $tokens 1 end] + + if {![catch {set methodInfo($prefix)} result]} { + # Prefix is known. If it's not a prefix, throw an + # error. + if {[lindex $result 0] == 0} { + error "$errRoot, \"$prefix\" has no submethods." + } + } + + set methodInfo($prefix) [list 1] + } + } +} + +# Defines a typemethod method. +proc ::snit::Comp.statement.typemethod {method arglist body} { + variable compile + variable typemethodInfo + + # FIRST, check the typemethod name against previously defined + # typemethods. + Comp.CheckMethodName $method 0 ::snit::typemethodInfo \ + "Error in \"typemethod [list $method]...\"" + + CheckArgs "typemethod $method" $arglist + + # First, add magic reference to type. + set arglist [concat type $arglist] + + # Next, add typevariable declarations to body: + set body "%TVARDECS%\n# END snit method prolog\n$body" + + # Next, save the definition script + if {[llength $method] == 1} { + set typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""} + + Mappend compile(defs) { + proc %TYPE%::Snit_typemethod%METHOD% %ARGLIST% %BODY% + } %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body] + } else { + set typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""} + + Mappend compile(defs) { + proc %TYPE%::Snit_htypemethod%JMETHOD% %ARGLIST% %BODY% + } %JMETHOD% [join $method _] \ + %ARGLIST% [list $arglist] %BODY% [list $body] + } +} + + +# Defines a type constructor. +proc ::snit::Comp.statement.typeconstructor {body} { + variable compile + + if {"" != $compile(typeconstructor)} { + error "too many typeconstructors" + } + + set compile(typeconstructor) $body +} + +# Defines a static proc in the type's namespace. +proc ::snit::Comp.statement.proc {proc arglist body} { + variable compile + + # If "ns" is defined, the proc can see instance variables. + if {[lsearch -exact $arglist selfns] != -1} { + # Next, add instance variable declarations to body: + set body "%IVARDECS%\n$body" + } + + # The proc can always see typevariables. + set body "%TVARDECS%\n$body" + + append compile(defs) " + + # Proc $proc + proc [list %TYPE%::$proc $arglist $body] + " +} + +# Defines a static variable in the type's namespace. +proc ::snit::Comp.statement.typevariable {name args} { + variable compile + + set errRoot "Error in \"typevariable $name...\"" + + set len [llength $args] + + if {$len > 2 || + ($len == 2 && [lindex $args 0] ne "-array")} { + error "$errRoot, too many initializers" + } + + if {[lsearch -exact $compile(varnames) $name] != -1} { + error "$errRoot, \"$name\" is already an instance variable" + } + + lappend compile(typevarnames) $name + + if {$len == 1} { + append compile(typevars) \ + "\n\t [list ::variable $name [lindex $args 0]]" + } elseif {$len == 2} { + append compile(typevars) \ + "\n\t [list ::variable $name]" + append compile(typevars) \ + "\n\t [list array set $name [lindex $args 1]]" + } else { + append compile(typevars) \ + "\n\t [list ::variable $name]" + } + + if {$compile(tvprocdec) eq ""} { + set compile(tvprocdec) "\n\t" + append compile(tvprocdec) "namespace upvar [list $compile(type)]" + } + append compile(tvprocdec) " [list $name $name]" +} + +# Defines an instance variable; the definition will go in the +# type's create typemethod. +proc ::snit::Comp.statement.variable {name args} { + variable compile + + set errRoot "Error in \"variable $name...\"" + + set len [llength $args] + + if {$len > 2 || + ($len == 2 && [lindex $args 0] ne "-array")} { + error "$errRoot, too many initializers" + } + + if {[lsearch -exact $compile(typevarnames) $name] != -1} { + error "$errRoot, \"$name\" is already a typevariable" + } + + lappend compile(varnames) $name + + # Add a ::variable to instancevars, so that ::variable is used + # at least once; ::variable makes the variable visible to + # [info vars] even if no value is assigned. + append compile(instancevars) "\n" + Mappend compile(instancevars) {::variable ${selfns}::%N} %N $name + + if {$len == 1} { + append compile(instancevars) \ + "\nset $name [list [lindex $args 0]]\n" + } elseif {$len == 2} { + append compile(instancevars) \ + "\narray set $name [list [lindex $args 1]]\n" + } + + if {$compile(ivprocdec) eq ""} { + set compile(ivprocdec) "\n\t" + append compile(ivprocdec) {namespace upvar $selfns} + } + append compile(ivprocdec) " [list $name $name]" +} + +# Defines a typecomponent, and handles component options. +# +# component The logical name of the delegate +# args options. + +proc ::snit::Comp.statement.typecomponent {component args} { + variable compile + + set errRoot "Error in \"typecomponent $component...\"" + + # FIRST, define the component + Comp.DefineTypecomponent $component $errRoot + + # NEXT, handle the options. + set publicMethod "" + set inheritFlag 0 + + foreach {opt val} $args { + switch -exact -- $opt { + -public { + set publicMethod $val + } + -inherit { + set inheritFlag $val + if {![string is boolean $inheritFlag]} { + error "typecomponent $component -inherit: expected boolean value, got \"$val\"" + } + } + default { + error "typecomponent $component: Invalid option \"$opt\"" + } + } + } + + # NEXT, if -public specified, define the method. + if {$publicMethod ne ""} { + Comp.statement.delegate typemethod [list $publicMethod *] to $component + } + + # NEXT, if "-inherit 1" is specified, delegate typemethod * to + # this component. + if {$inheritFlag} { + Comp.statement.delegate typemethod "*" to $component + } + +} + + +# Defines a name to be a typecomponent +# +# The name becomes a typevariable; in addition, it gets a +# write trace so that when it is set, all of the component mechanisms +# get updated. +# +# component The component name + +proc ::snit::Comp.DefineTypecomponent {component {errRoot "Error"}} { + variable compile + + if {[lsearch -exact $compile(varnames) $component] != -1} { + error "$errRoot, \"$component\" is already an instance variable" + } + + if {[lsearch -exact $compile(typecomponents) $component] == -1} { + # Remember we've done this. + lappend compile(typecomponents) $component + + # Make it a type variable with no initial value + Comp.statement.typevariable $component "" + + # Add a write trace to do the component thing. + Mappend compile(typevars) { + trace add variable %COMP% write \ + [list ::snit::RT.TypecomponentTrace [list %TYPE%] %COMP%] + } %TYPE% $compile(type) %COMP% $component + } +} + +# Defines a component, and handles component options. +# +# component The logical name of the delegate +# args options. +# +# TBD: Ideally, it should be possible to call this statement multiple +# times, possibly changing the option values. To do that, I'd need +# to cache the option values and not act on them until *after* I'd +# read the entire type definition. + +proc ::snit::Comp.statement.component {component args} { + variable compile + + set errRoot "Error in \"component $component...\"" + + # FIRST, define the component + Comp.DefineComponent $component $errRoot + + # NEXT, handle the options. + set publicMethod "" + set inheritFlag 0 + + foreach {opt val} $args { + switch -exact -- $opt { + -public { + set publicMethod $val + } + -inherit { + set inheritFlag $val + if {![string is boolean $inheritFlag]} { + error "component $component -inherit: expected boolean value, got \"$val\"" + } + } + default { + error "component $component: Invalid option \"$opt\"" + } + } + } + + # NEXT, if -public specified, define the method. + if {$publicMethod ne ""} { + Comp.statement.delegate method [list $publicMethod *] to $component + } + + # NEXT, if -inherit is specified, delegate method/option * to + # this component. + if {$inheritFlag} { + Comp.statement.delegate method "*" to $component + Comp.statement.delegate option "*" to $component + } +} + + +# Defines a name to be a component +# +# The name becomes an instance variable; in addition, it gets a +# write trace so that when it is set, all of the component mechanisms +# get updated. +# +# component The component name + +proc ::snit::Comp.DefineComponent {component {errRoot "Error"}} { + variable compile + + if {[lsearch -exact $compile(typevarnames) $component] != -1} { + error "$errRoot, \"$component\" is already a typevariable" + } + + if {[lsearch -exact $compile(components) $component] == -1} { + # Remember we've done this. + lappend compile(components) $component + + # Make it an instance variable with no initial value + Comp.statement.variable $component "" + + # Add a write trace to do the component thing. + Mappend compile(instancevars) { + trace add variable ${selfns}::%COMP% write \ + [list ::snit::RT.ComponentTrace [list %TYPE%] $selfns %COMP%] + } %TYPE% $compile(type) %COMP% $component + } +} + +# Creates a delegated method, typemethod, or option. +proc ::snit::Comp.statement.delegate {what name args} { + # FIRST, dispatch to correct handler. + switch $what { + typemethod { Comp.DelegatedTypemethod $name $args } + method { Comp.DelegatedMethod $name $args } + option { Comp.DelegatedOption $name $args } + default { + error "Error in \"delegate $what $name...\", \"$what\"?" + } + } + + if {([llength $args] % 2) != 0} { + error "Error in \"delegate $what $name...\", invalid syntax" + } +} + +# Creates a delegated typemethod delegating it to a particular +# typecomponent or an arbitrary command. +# +# method The name of the method +# arglist Delegation options + +proc ::snit::Comp.DelegatedTypemethod {method arglist} { + variable compile + variable typemethodInfo + + set errRoot "Error in \"delegate typemethod [list $method]...\"" + + # Next, parse the delegation options. + set component "" + set target "" + set exceptions {} + set pattern "" + set methodTail [lindex $method end] + + foreach {opt value} $arglist { + switch -exact $opt { + to { set component $value } + as { set target $value } + except { set exceptions $value } + using { set pattern $value } + default { + error "$errRoot, unknown delegation option \"$opt\"" + } + } + } + + if {$component eq "" && $pattern eq ""} { + error "$errRoot, missing \"to\"" + } + + if {$methodTail eq "*" && $target ne ""} { + error "$errRoot, cannot specify \"as\" with \"*\"" + } + + if {$methodTail ne "*" && $exceptions ne ""} { + error "$errRoot, can only specify \"except\" with \"*\"" + } + + if {$pattern ne "" && $target ne ""} { + error "$errRoot, cannot specify both \"as\" and \"using\"" + } + + foreach token [lrange $method 1 end-1] { + if {$token eq "*"} { + error "$errRoot, \"*\" must be the last token." + } + } + + # NEXT, define the component + if {$component ne ""} { + Comp.DefineTypecomponent $component $errRoot + } + + # NEXT, define the pattern. + if {$pattern eq ""} { + if {$methodTail eq "*"} { + set pattern "%c %m" + } elseif {$target ne ""} { + set pattern "%c $target" + } else { + set pattern "%c %m" + } + } + + # Make sure the pattern is a valid list. + if {[catch {lindex $pattern 0} result]} { + error "$errRoot, the using pattern, \"$pattern\", is not a valid list" + } + + # NEXT, check the method name against previously defined + # methods. + Comp.CheckMethodName $method 1 ::snit::typemethodInfo $errRoot + + set typemethodInfo($method) [list 0 $pattern $component] + + if {[string equal $methodTail "*"]} { + Mappend compile(defs) { + set %TYPE%::Snit_info(excepttypemethods) %EXCEPT% + } %EXCEPT% [list $exceptions] + } +} + + +# Creates a delegated method delegating it to a particular +# component or command. +# +# method The name of the method +# arglist Delegation options. + +proc ::snit::Comp.DelegatedMethod {method arglist} { + variable compile + variable methodInfo + + set errRoot "Error in \"delegate method [list $method]...\"" + + # Next, parse the delegation options. + set component "" + set target "" + set exceptions {} + set pattern "" + set methodTail [lindex $method end] + + foreach {opt value} $arglist { + switch -exact $opt { + to { set component $value } + as { set target $value } + except { set exceptions $value } + using { set pattern $value } + default { + error "$errRoot, unknown delegation option \"$opt\"" + } + } + } + + if {$component eq "" && $pattern eq ""} { + error "$errRoot, missing \"to\"" + } + + if {$methodTail eq "*" && $target ne ""} { + error "$errRoot, cannot specify \"as\" with \"*\"" + } + + if {$methodTail ne "*" && $exceptions ne ""} { + error "$errRoot, can only specify \"except\" with \"*\"" + } + + if {$pattern ne "" && $target ne ""} { + error "$errRoot, cannot specify both \"as\" and \"using\"" + } + + foreach token [lrange $method 1 end-1] { + if {$token eq "*"} { + error "$errRoot, \"*\" must be the last token." + } + } + + # NEXT, we delegate some methods + set compile(delegatesmethods) yes + + # NEXT, define the component. Allow typecomponents. + if {$component ne ""} { + if {[lsearch -exact $compile(typecomponents) $component] == -1} { + Comp.DefineComponent $component $errRoot + } + } + + # NEXT, define the pattern. + if {$pattern eq ""} { + if {$methodTail eq "*"} { + set pattern "%c %m" + } elseif {$target ne ""} { + set pattern "%c $target" + } else { + set pattern "%c %m" + } + } + + # Make sure the pattern is a valid list. + if {[catch {lindex $pattern 0} result]} { + error "$errRoot, the using pattern, \"$pattern\", is not a valid list" + } + + # NEXT, check the method name against previously defined + # methods. + Comp.CheckMethodName $method 1 ::snit::methodInfo $errRoot + + # NEXT, save the method info. + set methodInfo($method) [list 0 $pattern $component] + + if {[string equal $methodTail "*"]} { + Mappend compile(defs) { + set %TYPE%::Snit_info(exceptmethods) %EXCEPT% + } %EXCEPT% [list $exceptions] + } +} + +# Creates a delegated option, delegating it to a particular +# component and, optionally, to a particular option of that +# component. +# +# optionDef The option definition +# args definition arguments. + +proc ::snit::Comp.DelegatedOption {optionDef arglist} { + variable compile + + # First, get the three option names. + set option [lindex $optionDef 0] + set resourceName [lindex $optionDef 1] + set className [lindex $optionDef 2] + + set errRoot "Error in \"delegate option [list $optionDef]...\"" + + # Next, parse the delegation options. + set component "" + set target "" + set exceptions {} + + foreach {opt value} $arglist { + switch -exact $opt { + to { set component $value } + as { set target $value } + except { set exceptions $value } + default { + error "$errRoot, unknown delegation option \"$opt\"" + } + } + } + + if {$component eq ""} { + error "$errRoot, missing \"to\"" + } + + if {$option eq "*" && $target ne ""} { + error "$errRoot, cannot specify \"as\" with \"delegate option *\"" + } + + if {$option ne "*" && $exceptions ne ""} { + error "$errRoot, can only specify \"except\" with \"delegate option *\"" + } + + # Next, validate the option name + + if {"*" != $option} { + if {![Comp.OptionNameIsValid $option]} { + error "$errRoot, badly named option \"$option\"" + } + } + + if {$option in $compile(localoptions)} { + error "$errRoot, \"$option\" has been defined locally" + } + + if {$option in $compile(delegatedoptions)} { + error "$errRoot, \"$option\" is multiply delegated" + } + + # NEXT, define the component + Comp.DefineComponent $component $errRoot + + # Next, define the target option, if not specified. + if {![string equal $option "*"] && + [string equal $target ""]} { + set target $option + } + + # NEXT, save the delegation data. + set compile(hasoptions) yes + + if {![string equal $option "*"]} { + lappend compile(delegatedoptions) $option + + # Next, compute the resource and class names, if they aren't + # already defined. + + if {"" == $resourceName} { + set resourceName [string range $option 1 end] + } + + if {"" == $className} { + set className [Capitalize $resourceName] + } + + Mappend compile(defs) { + set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 0 + set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RES% + set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS% + lappend %TYPE%::Snit_optionInfo(delegated) %OPTION% + set %TYPE%::Snit_optionInfo(target-%OPTION%) [list %COMP% %TARGET%] + lappend %TYPE%::Snit_optionInfo(delegated-%COMP%) %OPTION% + } %OPTION% $option \ + %COMP% $component \ + %TARGET% $target \ + %RES% $resourceName \ + %CLASS% $className + } else { + Mappend compile(defs) { + set %TYPE%::Snit_optionInfo(starcomp) %COMP% + set %TYPE%::Snit_optionInfo(except) %EXCEPT% + } %COMP% $component %EXCEPT% [list $exceptions] + } +} + +# Exposes a component, effectively making the component's command an +# instance method. +# +# component The logical name of the delegate +# "as" sugar; if not "", must be "as" +# methodname The desired method name for the component's command, or "" + +proc ::snit::Comp.statement.expose {component {"as" ""} {methodname ""}} { + variable compile + + + # FIRST, define the component + Comp.DefineComponent $component + + # NEXT, define the method just as though it were in the type + # definition. + if {[string equal $methodname ""]} { + set methodname $component + } + + Comp.statement.method $methodname args [Expand { + if {[llength $args] == 0} { + return $%COMPONENT% + } + + if {[string equal $%COMPONENT% ""]} { + error "undefined component \"%COMPONENT%\"" + } + + + set cmd [linsert $args 0 $%COMPONENT%] + return [uplevel 1 $cmd] + } %COMPONENT% $component] +} + + + +#----------------------------------------------------------------------- +# Public commands + +# Compile a type definition, and return the results as a list of two +# items: the fully-qualified type name, and a script that will define +# the type when executed. +# +# which type, widget, or widgetadaptor +# type the type name +# body the type definition +proc ::snit::compile {which type body} { + return [Comp.Compile $which $type $body] +} + +proc ::snit::type {type body} { + return [Comp.Define [Comp.Compile type $type $body]] +} + +proc ::snit::widget {type body} { + return [Comp.Define [Comp.Compile widget $type $body]] +} + +proc ::snit::widgetadaptor {type body} { + return [Comp.Define [Comp.Compile widgetadaptor $type $body]] +} + +proc ::snit::typemethod {type method arglist body} { + # Make sure the type exists. + if {![info exists ::${type}::Snit_info]} { + error "no such type: \"$type\"" + } + + upvar ::${type}::Snit_info Snit_info + upvar ::${type}::Snit_typemethodInfo Snit_typemethodInfo + + # FIRST, check the typemethod name against previously defined + # typemethods. + Comp.CheckMethodName $method 0 ::${type}::Snit_typemethodInfo \ + "Cannot define \"$method\"" + + # NEXT, check the arguments + CheckArgs "snit::typemethod $type $method" $arglist + + # Next, add magic reference to type. + set arglist [concat type $arglist] + + # Next, add typevariable declarations to body: + set body "$Snit_info(tvardecs)\n$body" + + # Next, define it. + if {[llength $method] == 1} { + set Snit_typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""} + uplevel 1 [list proc ${type}::Snit_typemethod$method $arglist $body] + } else { + set Snit_typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""} + set suffix [join $method _] + uplevel 1 [list proc ${type}::Snit_htypemethod$suffix $arglist $body] + } +} + +proc ::snit::method {type method arglist body} { + # Make sure the type exists. + if {![info exists ::${type}::Snit_info]} { + error "no such type: \"$type\"" + } + + upvar ::${type}::Snit_methodInfo Snit_methodInfo + upvar ::${type}::Snit_info Snit_info + + # FIRST, check the method name against previously defined + # methods. + Comp.CheckMethodName $method 0 ::${type}::Snit_methodInfo \ + "Cannot define \"$method\"" + + # NEXT, check the arguments + CheckArgs "snit::method $type $method" $arglist + + # Next, add magic references to type and self. + set arglist [concat type selfns win self $arglist] + + # Next, add variable declarations to body: + set body "$Snit_info(tvardecs)\n$Snit_info(ivardecs)\n$body" + + # Next, define it. + if {[llength $method] == 1} { + set Snit_methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""} + uplevel 1 [list proc ${type}::Snit_method$method $arglist $body] + } else { + set Snit_methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""} + + set suffix [join $method _] + uplevel 1 [list proc ${type}::Snit_hmethod$suffix $arglist $body] + } +} + +# Defines a proc within the compiler; this proc can call other +# type definition statements, and thus can be used for meta-programming. +proc ::snit::macro {name arglist body} { + variable compiler + variable reservedwords + + # FIRST, make sure the compiler is defined. + Comp.Init + + # NEXT, check the macro name against the reserved words + if {[lsearch -exact $reservedwords $name] != -1} { + error "invalid macro name \"$name\"" + } + + # NEXT, see if the name has a namespace; if it does, define the + # namespace. + set ns [namespace qualifiers $name] + + if {$ns ne ""} { + $compiler eval "namespace eval $ns {}" + } + + # NEXT, define the macro + $compiler eval [list _proc $name $arglist $body] +} + +#----------------------------------------------------------------------- +# Utility Functions +# +# These are utility functions used while compiling Snit types. + +# Builds a template from a tagged list of text blocks, then substitutes +# all symbols in the mapTable, returning the expanded template. +proc ::snit::Expand {template args} { + return [string map $args $template] +} + +# Expands a template and appends it to a variable. +proc ::snit::Mappend {varname template args} { + upvar $varname myvar + + append myvar [string map $args $template] +} + +# Checks argument list against reserved args +proc ::snit::CheckArgs {which arglist} { + variable reservedArgs + + foreach name $reservedArgs { + if {$name in $arglist} { + error "$which's arglist may not contain \"$name\" explicitly" + } + } +} + +# Capitalizes the first letter of a string. +proc ::snit::Capitalize {text} { + return [string toupper $text 0] +} + + +#======================================================================= +# Snit Runtime Library +# +# These are procs used by Snit types and widgets at runtime. + +#----------------------------------------------------------------------- +# Object Creation + +# Creates a new instance of the snit::type given its name and the args. +# +# type The snit::type +# name The instance name +# args Args to pass to the constructor + +proc ::snit::RT.type.typemethod.create {type name args} { + variable ${type}::Snit_info + variable ${type}::Snit_optionInfo + + # FIRST, qualify the name. + if {![string match "::*" $name]} { + # Get caller's namespace; + # append :: if not global namespace. + set ns [uplevel 1 [list namespace current]] + if {"::" != $ns} { + append ns "::" + } + + set name "$ns$name" + } + + # NEXT, if %AUTO% appears in the name, generate a unique + # command name. Otherwise, ensure that the name isn't in use. + if {[string match "*%AUTO%*" $name]} { + set name [::snit::RT.UniqueName Snit_info(counter) $type $name] + } elseif {!$Snit_info(canreplace) && [llength [info commands $name]]} { + error "command \"$name\" already exists" + } + + # NEXT, create the instance's namespace. + set selfns \ + [::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type] + namespace eval $selfns {} + + # NEXT, install the dispatcher + RT.MakeInstanceCommand $type $selfns $name + + # Initialize the options to their defaults. + namespace upvar ${selfns} options options + + foreach opt $Snit_optionInfo(local) { + set options($opt) $Snit_optionInfo(default-$opt) + } + + # Initialize the instance vars to their defaults. + # selfns must be defined, as it is used implicitly. + ${type}::Snit_instanceVars $selfns + + # Execute the type's constructor. + set errcode [catch { + RT.ConstructInstance $type $selfns $name $args + } result] + + if {$errcode} { + global errorInfo + global errorCode + + set theInfo $errorInfo + set theCode $errorCode + + ::snit::RT.DestroyObject $type $selfns $name + error "Error in constructor: $result" $theInfo $theCode + } + + # NEXT, return the object's name. + return $name +} + +# Creates a new instance of the snit::widget or snit::widgetadaptor +# given its name and the args. +# +# type The snit::widget or snit::widgetadaptor +# name The instance name +# args Args to pass to the constructor + +proc ::snit::RT.widget.typemethod.create {type name args} { + variable ${type}::Snit_info + variable ${type}::Snit_optionInfo + + # FIRST, if %AUTO% appears in the name, generate a unique + # command name. + if {[string match "*%AUTO%*" $name]} { + set name [::snit::RT.UniqueName Snit_info(counter) $type $name] + } + + # NEXT, create the instance's namespace. + set selfns \ + [::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type] + namespace eval $selfns { } + + # NEXT, Initialize the widget's own options to their defaults. + namespace upvar $selfns options options + + foreach opt $Snit_optionInfo(local) { + set options($opt) $Snit_optionInfo(default-$opt) + } + + # Initialize the instance vars to their defaults. + ${type}::Snit_instanceVars $selfns + + # NEXT, if this is a normal widget (not a widget adaptor) then create a + # frame as its hull. We set the frame's -class to the user's widgetclass, + # or, if none, search for -class in the args list, otherwise default to + # the basename of the $type with an initial upper case letter. + if {!$Snit_info(isWidgetAdaptor)} { + # FIRST, determine the class name + set wclass $Snit_info(widgetclass) + if {$Snit_info(widgetclass) eq ""} { + set idx [lsearch -exact $args -class] + if {$idx >= 0 && ($idx%2 == 0)} { + # -class exists and is in the -option position + set wclass [lindex $args [expr {$idx+1}]] + set args [lreplace $args $idx [expr {$idx+1}]] + } else { + set wclass [::snit::Capitalize [namespace tail $type]] + } + } + + # NEXT, create the widget + set self $name + package require Tk + ${type}::installhull using $Snit_info(hulltype) -class $wclass + + # NEXT, let's query the option database for our + # widget, now that we know that it exists. + foreach opt $Snit_optionInfo(local) { + set dbval [RT.OptionDbGet $type $name $opt] + + if {"" != $dbval} { + set options($opt) $dbval + } + } + } + + # Execute the type's constructor, and verify that it + # has a hull. + set errcode [catch { + RT.ConstructInstance $type $selfns $name $args + + ::snit::RT.Component $type $selfns hull + + # Prepare to call the object's destructor when the + # event is received. Use a Snit-specific bindtag + # so that the widget name's tag is unencumbered. + + bind Snit$type$name [::snit::Expand { + ::snit::RT.DestroyObject %TYPE% %NS% %W + } %TYPE% $type %NS% $selfns] + + # Insert the bindtag into the list of bindtags right + # after the widget name. + set taglist [bindtags $name] + set ndx [lsearch -exact $taglist $name] + incr ndx + bindtags $name [linsert $taglist $ndx Snit$type$name] + } result] + + if {$errcode} { + global errorInfo + global errorCode + + set theInfo $errorInfo + set theCode $errorCode + ::snit::RT.DestroyObject $type $selfns $name + error "Error in constructor: $result" $theInfo $theCode + } + + # NEXT, return the object's name. + return $name +} + + +# RT.MakeInstanceCommand type selfns instance +# +# type The object type +# selfns The instance namespace +# instance The instance name +# +# Creates the instance proc. + +proc ::snit::RT.MakeInstanceCommand {type selfns instance} { + variable ${type}::Snit_info + + # FIRST, remember the instance name. The Snit_instance variable + # allows the instance to figure out its current name given the + # instance namespace. + + namespace upvar $selfns Snit_instance Snit_instance + + set Snit_instance $instance + + # NEXT, qualify the proc name if it's a widget. + if {$Snit_info(isWidget)} { + set procname ::$instance + } else { + set procname $instance + } + + # NEXT, install the new proc + # WHD: Snit 2.0 code + + set unknownCmd [list ::snit::RT.UnknownMethod $type $selfns $instance ""] + set createCmd [list namespace ensemble create \ + -command $procname \ + -unknown $unknownCmd \ + -prefixes 0] + + namespace eval $selfns $createCmd + + # NEXT, add the trace. + trace add command $procname {rename delete} \ + [list ::snit::RT.InstanceTrace $type $selfns $instance] +} + +# This proc is called when the instance command is renamed. +# If op is delete, then new will always be "", so op is redundant. +# +# type The fully-qualified type name +# selfns The instance namespace +# win The original instance/tk window name. +# old old instance command name +# new new instance command name +# op rename or delete +# +# If the op is delete, we need to clean up the object; otherwise, +# we need to track the change. +# +# NOTE: In Tcl 8.4.2 there's a bug: errors in rename and delete +# traces aren't propagated correctly. Instead, they silently +# vanish. Add a catch to output any error message. + +proc ::snit::RT.InstanceTrace {type selfns win old new op} { + variable ${type}::Snit_info + + # Note to developers ... + # For Tcl 8.4.0, errors thrown in trace handlers vanish silently. + # Therefore we catch them here and create some output to help in + # debugging such problems. + + if {[catch { + # FIRST, clean up if necessary + if {"" == $new} { + if {$Snit_info(isWidget)} { + destroy $win + } else { + ::snit::RT.DestroyObject $type $selfns $win + } + } else { + # Otherwise, track the change. + variable ${selfns}::Snit_instance + set Snit_instance [uplevel 1 [list namespace which -command $new]] + + # Also, clear the instance caches, as many cached commands + # might be invalid. + RT.ClearInstanceCaches $selfns + } + } result]} { + global errorInfo + # Pop up the console on Windows wish, to enable stdout. + # This clobbers errorInfo on unix, so save it so we can print it. + set ei $errorInfo + catch {console show} + puts "Error in ::snit::RT.InstanceTrace $type $selfns $win $old $new $op:" + puts $ei + } +} + +# Calls the instance constructor and handles related housekeeping. +proc ::snit::RT.ConstructInstance {type selfns instance arglist} { + variable ${type}::Snit_optionInfo + variable ${selfns}::Snit_iinfo + + # Track whether we are constructed or not. + set Snit_iinfo(constructed) 0 + + # Call the user's constructor + eval [linsert $arglist 0 \ + ${type}::Snit_constructor $type $selfns $instance $instance] + + set Snit_iinfo(constructed) 1 + + # Validate the initial set of options (including defaults) + foreach option $Snit_optionInfo(local) { + set value [set ${selfns}::options($option)] + + if {$Snit_optionInfo(typespec-$option) ne ""} { + if {[catch { + $Snit_optionInfo(typeobj-$option) validate $value + } result]} { + return -code error "invalid $option default: $result" + } + } + } + + # Unset the configure cache for all -readonly options. + # This ensures that the next time anyone tries to + # configure it, an error is thrown. + foreach opt $Snit_optionInfo(local) { + if {$Snit_optionInfo(readonly-$opt)} { + unset -nocomplain ${selfns}::Snit_configureCache($opt) + } + } + + return +} + +# Returns a unique command name. +# +# REQUIRE: type is a fully qualified name. +# REQUIRE: name contains "%AUTO%" +# PROMISE: the returned command name is unused. +proc ::snit::RT.UniqueName {countervar type name} { + upvar $countervar counter + while 1 { + # FIRST, bump the counter and define the %AUTO% instance name; + # then substitute it into the specified name. Wrap around at + # 2^31 - 2 to prevent overflow problems. + incr counter + if {$counter > 2147483646} { + set counter 0 + } + set auto "[namespace tail $type]$counter" + set candidate [Expand $name %AUTO% $auto] + if {![llength [info commands $candidate]]} { + return $candidate + } + } +} + +# Returns a unique instance namespace, fully qualified. +# +# countervar The name of a counter variable +# type The instance's type +# +# REQUIRE: type is fully qualified +# PROMISE: The returned namespace name is unused. + +proc ::snit::RT.UniqueInstanceNamespace {countervar type} { + upvar $countervar counter + while 1 { + # FIRST, bump the counter and define the namespace name. + # Then see if it already exists. Wrap around at + # 2^31 - 2 to prevent overflow problems. + incr counter + if {$counter > 2147483646} { + set counter 0 + } + set ins "${type}::Snit_inst${counter}" + if {![namespace exists $ins]} { + return $ins + } + } +} + +# Retrieves an option's value from the option database. +# Returns "" if no value is found. +proc ::snit::RT.OptionDbGet {type self opt} { + variable ${type}::Snit_optionInfo + + return [option get $self \ + $Snit_optionInfo(resource-$opt) \ + $Snit_optionInfo(class-$opt)] +} + +#----------------------------------------------------------------------- +# Object Destruction + +# Implements the standard "destroy" method +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name + +proc ::snit::RT.method.destroy {type selfns win self} { + variable ${selfns}::Snit_iinfo + + # Can't destroy the object if it isn't complete constructed. + if {!$Snit_iinfo(constructed)} { + return -code error "Called 'destroy' method in constructor" + } + + # Calls Snit_cleanup, which (among other things) calls the + # user's destructor. + ::snit::RT.DestroyObject $type $selfns $win +} + +# This is the function that really cleans up; it's automatically +# called when any instance is destroyed, e.g., by "$object destroy" +# for types, and by the event for widgets. +# +# type The fully-qualified type name. +# selfns The instance namespace +# win The original instance command name. + +proc ::snit::RT.DestroyObject {type selfns win} { + variable ${type}::Snit_info + + # If the variable Snit_instance doesn't exist then there's no + # instance command for this object -- it's most likely a + # widgetadaptor. Consequently, there are some things that + # we don't need to do. + if {[info exists ${selfns}::Snit_instance]} { + namespace upvar $selfns Snit_instance instance + + # First, remove the trace on the instance name, so that we + # don't call RT.DestroyObject recursively. + RT.RemoveInstanceTrace $type $selfns $win $instance + + # Next, call the user's destructor + ${type}::Snit_destructor $type $selfns $win $instance + + # Next, if this isn't a widget, delete the instance command. + # If it is a widget, get the hull component's name, and rename + # it back to the widget name + + # Next, delete the hull component's instance command, + # if there is one. + if {$Snit_info(isWidget)} { + set hullcmd [::snit::RT.Component $type $selfns hull] + + catch {rename $instance ""} + + # Clear the bind event + bind Snit$type$win "" + + if {[llength [info commands $hullcmd]]} { + # FIRST, rename the hull back to its original name. + # If the hull is itself a megawidget, it will have its + # own cleanup to do, and it might not do it properly + # if it doesn't have the right name. + rename $hullcmd ::$instance + + # NEXT, destroy it. + destroy $instance + } + } else { + catch {rename $instance ""} + } + } + + # Next, delete the instance's namespace. This kills any + # instance variables. + namespace delete $selfns + + return +} + +# Remove instance trace +# +# type The fully qualified type name +# selfns The instance namespace +# win The original instance name/Tk window name +# instance The current instance name + +proc ::snit::RT.RemoveInstanceTrace {type selfns win instance} { + variable ${type}::Snit_info + + if {$Snit_info(isWidget)} { + set procname ::$instance + } else { + set procname $instance + } + + # NEXT, remove any trace on this name + catch { + trace remove command $procname {rename delete} \ + [list ::snit::RT.InstanceTrace $type $selfns $win] + } +} + +#----------------------------------------------------------------------- +# Typecomponent Management and Method Caching + +# Typecomponent trace; used for write trace on typecomponent +# variables. Saves the new component object name, provided +# that certain conditions are met. Also clears the typemethod +# cache. + +proc ::snit::RT.TypecomponentTrace {type component n1 n2 op} { + namespace upvar $type \ + Snit_info Snit_info \ + $component cvar \ + Snit_typecomponents Snit_typecomponents + + + # Save the new component value. + set Snit_typecomponents($component) $cvar + + # Clear the typemethod cache. + # TBD: can we unset just the elements related to + # this component? + + # WHD: Namespace 2.0 code + namespace ensemble configure $type -map {} +} + +# WHD: Snit 2.0 code +# +# RT.UnknownTypemethod type eId eCmd method args +# +# type The type +# eId The ensemble command ID; "" for the instance itself. +# eCmd The ensemble command name. +# method The unknown method name. +# args The additional arguments, if any. +# +# This proc looks up the method relative to the specified ensemble. +# If no method is found, it assumes that the "create" method is +# desired, and that the "method" is the instance name. In this case, +# it returns the "create" typemethod command with the instance name +# appended; this will cause the instance to be created without updating +# the -map. If the method is found, the method's command is created and +# added to the -map; the function returns the empty list. + +proc snit::RT.UnknownTypemethod {type eId eCmd method args} { + namespace upvar $type \ + Snit_typemethodInfo Snit_typemethodInfo \ + Snit_typecomponents Snit_typecomponents \ + Snit_info Snit_info + + # FIRST, get the pattern data and the typecomponent name. + set implicitCreate 0 + set instanceName "" + + set fullMethod $eId + lappend fullMethod $method + set starredMethod [concat $eId *] + set methodTail $method + + if {[info exists Snit_typemethodInfo($fullMethod)]} { + set key $fullMethod + } elseif {[info exists Snit_typemethodInfo($starredMethod)]} { + if {[lsearch -exact $Snit_info(excepttypemethods) $methodTail] == -1} { + set key $starredMethod + } else { + # WHD: The method is explicitly not delegated, so this is an error. + # Or should we treat it as an instance name? + return [list ] + } + } elseif {[llength $fullMethod] > 1} { + return [list ] + } elseif {$Snit_info(hasinstances)} { + # Assume the unknown name is an instance name to create, unless + # this is a widget and the style of the name is wrong, or the + # name mimics a standard typemethod. + + if {[set ${type}::Snit_info(isWidget)] && + ![string match ".*" $method]} { + return [list ] + } + + # Without this check, the call "$type info" will redefine the + # standard "::info" command, with disastrous results. Since it's + # a likely thing to do if !-typeinfo, put in an explicit check. + if {$method eq "info" || $method eq "destroy"} { + return [list ] + } + + set implicitCreate 1 + set instanceName $method + set key create + set method create + } else { + return [list ] + } + + foreach {flag pattern compName} $Snit_typemethodInfo($key) {} + + if {$flag == 1} { + # FIRST, define the ensemble command. + lappend eId $method + + set newCmd ${type}::Snit_ten[llength $eId]_[join $eId _] + + set unknownCmd [list ::snit::RT.UnknownTypemethod \ + $type $eId] + + set createCmd [list namespace ensemble create \ + -command $newCmd \ + -unknown $unknownCmd \ + -prefixes 0] + + namespace eval $type $createCmd + + # NEXT, add the method to the current ensemble + set map [namespace ensemble configure $eCmd -map] + + dict append map $method $newCmd + + namespace ensemble configure $eCmd -map $map + + return [list ] + } + + # NEXT, build the substitution list + set subList [list \ + %% % \ + %t $type \ + %M $fullMethod \ + %m [lindex $fullMethod end] \ + %j [join $fullMethod _]] + + if {$compName ne ""} { + if {![info exists Snit_typecomponents($compName)]} { + error "$type delegates typemethod \"$method\" to undefined typecomponent \"$compName\"" + } + + lappend subList %c [list $Snit_typecomponents($compName)] + } + + set command {} + + foreach subpattern $pattern { + lappend command [string map $subList $subpattern] + } + + if {$implicitCreate} { + # In this case, $method is the name of the instance to + # create. Don't cache, as we usually won't do this one + # again. + lappend command $instanceName + return $command + } + + + # NEXT, if the actual command name isn't fully qualified, + # assume it's global. + set cmd [lindex $command 0] + + if {[string index $cmd 0] ne ":"} { + set command [lreplace $command 0 0 "::$cmd"] + } + + # NEXT, update the ensemble map. + set map [namespace ensemble configure $eCmd -map] + + dict append map $method $command + + namespace ensemble configure $eCmd -map $map + + return [list ] +} + +#----------------------------------------------------------------------- +# Component Management and Method Caching + +# Retrieves the object name given the component name. +proc ::snit::RT.Component {type selfns name} { + variable ${selfns}::Snit_components + + if {[catch {set Snit_components($name)} result]} { + variable ${selfns}::Snit_instance + + error "component \"$name\" is undefined in $type $Snit_instance" + } + + return $result +} + +# Component trace; used for write trace on component instance +# variables. Saves the new component object name, provided +# that certain conditions are met. Also clears the method +# cache. + +proc ::snit::RT.ComponentTrace {type selfns component n1 n2 op} { + namespace upvar $type Snit_info Snit_info + namespace upvar $selfns \ + $component cvar \ + Snit_components Snit_components + + # If they try to redefine the hull component after + # it's been defined, that's an error--but only if + # this is a widget or widget adaptor. + if {"hull" == $component && + $Snit_info(isWidget) && + [info exists Snit_components($component)]} { + set cvar $Snit_components($component) + error "The hull component cannot be redefined" + } + + # Save the new component value. + set Snit_components($component) $cvar + + # Clear the instance caches. + # TBD: can we unset just the elements related to + # this component? + RT.ClearInstanceCaches $selfns +} + +# WHD: Snit 2.0 code +# +# RT.UnknownMethod type selfns win eId eCmd method args +# +# type The type or widget command. +# selfns The instance namespace. +# win The original instance name. +# eId The ensemble command ID; "" for the instance itself. +# eCmd The real ensemble command name +# method The unknown method name +# args The additional arguments, if any. +# +# This proc looks up the method relative to the specific ensemble. +# If no method is found, it returns an empty list; this will result in +# the parent ensemble throwing an error. +# If the method is found, the ensemble's -map is extended with the +# correct command, and the empty list is returned; this caches the +# method's command. If the method is found, and it is also an +# ensemble, the ensemble command is created with an empty map. + +proc ::snit::RT.UnknownMethod {type selfns win eId eCmd method args} { + variable ${type}::Snit_info + variable ${type}::Snit_methodInfo + variable ${type}::Snit_typecomponents + variable ${selfns}::Snit_components + + # FIRST, get the "self" value + set self [set ${selfns}::Snit_instance] + + # FIRST, get the pattern data and the component name. + set fullMethod $eId + lappend fullMethod $method + set starredMethod [concat $eId *] + set methodTail $method + + if {[info exists Snit_methodInfo($fullMethod)]} { + set key $fullMethod + } elseif {[info exists Snit_methodInfo($starredMethod)] && + [lsearch -exact $Snit_info(exceptmethods) $methodTail] == -1} { + set key $starredMethod + } else { + return [list ] + } + + foreach {flag pattern compName} $Snit_methodInfo($key) {} + + if {$flag == 1} { + # FIRST, define the ensemble command. + lappend eId $method + + # Fix provided by Anton Kovalenko; previously this call erroneously + # used ${type} rather than ${selfns}. + set newCmd ${selfns}::Snit_en[llength $eId]_[join $eId _] + + set unknownCmd [list ::snit::RT.UnknownMethod \ + $type $selfns $win $eId] + + set createCmd [list namespace ensemble create \ + -command $newCmd \ + -unknown $unknownCmd \ + -prefixes 0] + + namespace eval $selfns $createCmd + + # NEXT, add the method to the current ensemble + set map [namespace ensemble configure $eCmd -map] + + dict append map $method $newCmd + + namespace ensemble configure $eCmd -map $map + + return [list ] + } + + # NEXT, build the substitution list + set subList [list \ + %% % \ + %t $type \ + %M $fullMethod \ + %m [lindex $fullMethod end] \ + %j [join $fullMethod _] \ + %n [list $selfns] \ + %w [list $win] \ + %s [list $self]] + + if {$compName ne ""} { + if {[info exists Snit_components($compName)]} { + set compCmd $Snit_components($compName) + } elseif {[info exists Snit_typecomponents($compName)]} { + set compCmd $Snit_typecomponents($compName) + } else { + error "$type $self delegates method \"$fullMethod\" to undefined component \"$compName\"" + } + + lappend subList %c [list $compCmd] + } + + # Note: The cached command will execute faster if it's + # already a list. + set command {} + + foreach subpattern $pattern { + lappend command [string map $subList $subpattern] + } + + # NEXT, if the actual command name isn't fully qualified, + # assume it's global. + + set cmd [lindex $command 0] + + if {[string index $cmd 0] ne ":"} { + set command [lreplace $command 0 0 "::$cmd"] + } + + # NEXT, update the ensemble map. + set map [namespace ensemble configure $eCmd -map] + + dict append map $method $command + + namespace ensemble configure $eCmd -map $map + + return [list ] +} + +# Clears all instance command caches +proc ::snit::RT.ClearInstanceCaches {selfns} { + # WHD: clear ensemble -map + if {![info exists ${selfns}::Snit_instance]} { + # Component variable set prior to constructor + # via the "variable" type definition statement. + return + } + set self [set ${selfns}::Snit_instance] + namespace ensemble configure $self -map {} + + unset -nocomplain -- ${selfns}::Snit_cgetCache + unset -nocomplain -- ${selfns}::Snit_configureCache + unset -nocomplain -- ${selfns}::Snit_validateCache +} + + +#----------------------------------------------------------------------- +# Component Installation + +# Implements %TYPE%::installhull. The variables self and selfns +# must be defined in the caller's context. +# +# Installs the named widget as the hull of a +# widgetadaptor. Once the widget is hijacked, its new name +# is assigned to the hull component. + +proc ::snit::RT.installhull {type {using "using"} {widgetType ""} args} { + variable ${type}::Snit_info + variable ${type}::Snit_optionInfo + upvar 1 self self + upvar 1 selfns selfns + namespace upvar $selfns \ + hull hull \ + options options + + # FIRST, make sure we can do it. + if {!$Snit_info(isWidget)} { + error "installhull is valid only for snit::widgetadaptors" + } + + if {[info exists ${selfns}::Snit_instance]} { + error "hull already installed for $type $self" + } + + # NEXT, has it been created yet? If not, create it using + # the specified arguments. + if {"using" == $using} { + # FIRST, create the widget + set cmd [linsert $args 0 $widgetType $self] + set obj [uplevel 1 $cmd] + + # NEXT, for each option explicitly delegated to the hull + # that doesn't appear in the usedOpts list, get the + # option database value and apply it--provided that the + # real option name and the target option name are different. + # (If they are the same, then the option database was + # already queried as part of the normal widget creation.) + # + # Also, we don't need to worry about implicitly delegated + # options, as the option and target option names must be + # the same. + if {[info exists Snit_optionInfo(delegated-hull)]} { + + # FIRST, extract all option names from args + set usedOpts {} + set ndx [lsearch -glob $args "-*"] + foreach {opt val} [lrange $args $ndx end] { + lappend usedOpts $opt + } + + foreach opt $Snit_optionInfo(delegated-hull) { + set target [lindex $Snit_optionInfo(target-$opt) 1] + + if {"$target" == $opt} { + continue + } + + set result [lsearch -exact $usedOpts $target] + + if {$result != -1} { + continue + } + + set dbval [RT.OptionDbGet $type $self $opt] + $obj configure $target $dbval + } + } + } else { + set obj $using + + if {$obj ne $self} { + error \ + "hull name mismatch: \"$obj\" != \"$self\"" + } + } + + # NEXT, get the local option defaults. + foreach opt $Snit_optionInfo(local) { + set dbval [RT.OptionDbGet $type $self $opt] + + if {"" != $dbval} { + set options($opt) $dbval + } + } + + + # NEXT, do the magic + set i 0 + while 1 { + incr i + set newName "::hull${i}$self" + if {![llength [info commands $newName]]} { + break + } + } + + rename ::$self $newName + RT.MakeInstanceCommand $type $selfns $self + + # Note: this relies on RT.ComponentTrace to do the dirty work. + set hull $newName + + return +} + +# Implements %TYPE%::install. +# +# Creates a widget and installs it as the named component. +# It expects self and selfns to be defined in the caller's context. + +proc ::snit::RT.install {type compName "using" widgetType winPath args} { + variable ${type}::Snit_optionInfo + variable ${type}::Snit_info + upvar 1 self self + upvar 1 selfns selfns + + namespace upvar ${selfns} \ + $compName comp \ + hull hull + + # We do the magic option database stuff only if $self is + # a widget. + if {$Snit_info(isWidget)} { + if {"" == $hull} { + error "tried to install \"$compName\" before the hull exists" + } + + # FIRST, query the option database and save the results + # into args. Insert them before the first option in the + # list, in case there are any non-standard parameters. + # + # Note: there might not be any delegated options; if so, + # don't bother. + + if {[info exists Snit_optionInfo(delegated-$compName)]} { + set ndx [lsearch -glob $args "-*"] + + foreach opt $Snit_optionInfo(delegated-$compName) { + set dbval [RT.OptionDbGet $type $self $opt] + + if {"" != $dbval} { + set target [lindex $Snit_optionInfo(target-$opt) 1] + set args [linsert $args $ndx $target $dbval] + } + } + } + } + + # NEXT, create the component and save it. + set cmd [concat [list $widgetType $winPath] $args] + set comp [uplevel 1 $cmd] + + # NEXT, handle the option database for "delegate option *", + # in widgets only. + if {$Snit_info(isWidget) && $Snit_optionInfo(starcomp) eq $compName} { + # FIRST, get the list of option specs from the widget. + # If configure doesn't work, skip it. + if {[catch {$comp configure} specs]} { + return + } + + # NEXT, get the set of explicitly used options from args + set usedOpts {} + set ndx [lsearch -glob $args "-*"] + foreach {opt val} [lrange $args $ndx end] { + lappend usedOpts $opt + } + + # NEXT, "delegate option *" matches all options defined + # by this widget that aren't defined by the widget as a whole, + # and that aren't excepted. Plus, we skip usedOpts. So build + # a list of the options it can't match. + set skiplist [concat \ + $usedOpts \ + $Snit_optionInfo(except) \ + $Snit_optionInfo(local) \ + $Snit_optionInfo(delegated)] + + # NEXT, loop over all of the component's options, and set + # any not in the skip list for which there is an option + # database value. + foreach spec $specs { + # Skip aliases + if {[llength $spec] != 5} { + continue + } + + set opt [lindex $spec 0] + + if {[lsearch -exact $skiplist $opt] != -1} { + continue + } + + set res [lindex $spec 1] + set cls [lindex $spec 2] + + set dbvalue [option get $self $res $cls] + + if {"" != $dbvalue} { + $comp configure $opt $dbvalue + } + } + } + + return +} + + +#----------------------------------------------------------------------- +# Method/Variable Name Qualification + +# Implements %TYPE%::variable. Requires selfns. +proc ::snit::RT.variable {varname} { + upvar 1 selfns selfns + + if {![string match "::*" $varname]} { + uplevel 1 [list upvar 1 ${selfns}::$varname $varname] + } else { + # varname is fully qualified; let the standard + # "variable" command handle it. + uplevel 1 [list ::variable $varname] + } +} + +# Fully qualifies a typevariable name. +# +# This is used to implement the mytypevar command. + +proc ::snit::RT.mytypevar {type name} { + return ${type}::$name +} + +# Fully qualifies an instance variable name. +# +# This is used to implement the myvar command. +proc ::snit::RT.myvar {name} { + upvar 1 selfns selfns + return ${selfns}::$name +} + +# Use this like "list" to convert a proc call into a command +# string to pass to another object (e.g., as a -command). +# Qualifies the proc name properly. +# +# This is used to implement the "myproc" command. + +proc ::snit::RT.myproc {type procname args} { + set procname "${type}::$procname" + return [linsert $args 0 $procname] +} + +# DEPRECATED +proc ::snit::RT.codename {type name} { + return "${type}::$name" +} + +# Use this like "list" to convert a typemethod call into a command +# string to pass to another object (e.g., as a -command). +# Inserts the type command at the beginning. +# +# This is used to implement the "mytypemethod" command. + +proc ::snit::RT.mytypemethod {type args} { + return [linsert $args 0 $type] +} + +# Use this like "list" to convert a method call into a command +# string to pass to another object (e.g., as a -command). +# Inserts the code at the beginning to call the right object, even if +# the object's name has changed. Requires that selfns be defined +# in the calling context, eg. can only be called in instance +# code. +# +# This is used to implement the "mymethod" command. + +proc ::snit::RT.mymethod {args} { + upvar 1 selfns selfns + return [linsert $args 0 ::snit::RT.CallInstance ${selfns}] +} + +# Calls an instance method for an object given its +# instance namespace and remaining arguments (the first of which +# will be the method name. +# +# selfns The instance namespace +# args The arguments +# +# Uses the selfns to determine $self, and calls the method +# in the normal way. +# +# This is used to implement the "mymethod" command. + +proc ::snit::RT.CallInstance {selfns args} { + namespace upvar $selfns Snit_instance self + + set retval [catch {uplevel 1 [linsert $args 0 $self]} result] + + if {$retval} { + if {$retval == 1} { + global errorInfo + global errorCode + return -code error -errorinfo $errorInfo \ + -errorcode $errorCode $result + } else { + return -code $retval $result + } + } + + return $result +} + +# Looks for the named option in the named variable. If found, +# it and its value are removed from the list, and the value +# is returned. Otherwise, the default value is returned. +# If the option is undelegated, it's own default value will be +# used if none is specified. +# +# Implements the "from" command. + +proc ::snit::RT.from {type argvName option {defvalue ""}} { + namespace upvar $type Snit_optionInfo Snit_optionInfo + upvar $argvName argv + + set ioption [lsearch -exact $argv $option] + + if {$ioption == -1} { + if {"" == $defvalue && + [info exists Snit_optionInfo(default-$option)]} { + return $Snit_optionInfo(default-$option) + } else { + return $defvalue + } + } + + set ivalue [expr {$ioption + 1}] + set value [lindex $argv $ivalue] + + set argv [lreplace $argv $ioption $ivalue] + + return $value +} + +#----------------------------------------------------------------------- +# Type Destruction + +# Implements the standard "destroy" typemethod: +# Destroys a type completely. +# +# type The snit type + +proc ::snit::RT.typemethod.destroy {type} { + variable ${type}::Snit_info + + # FIRST, destroy all instances + foreach selfns [namespace children $type "${type}::Snit_inst*"] { + if {![namespace exists $selfns]} { + continue + } + + namespace upvar $selfns Snit_instance obj + + if {$Snit_info(isWidget)} { + destroy $obj + } else { + if {[llength [info commands $obj]]} { + $obj destroy + } + } + } + + # NEXT, get rid of the type command. + rename $type "" + + # NEXT, destroy the type's data. + namespace delete $type +} + + + +#----------------------------------------------------------------------- +# Option Handling + +# Implements the standard "cget" method +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name +# option The name of the option + +proc ::snit::RT.method.cget {type selfns win self option} { + if {[catch {set ${selfns}::Snit_cgetCache($option)} command]} { + set command [snit::RT.CacheCgetCommand $type $selfns $win $self $option] + + if {[llength $command] == 0} { + return -code error "unknown option \"$option\"" + } + } + + uplevel 1 $command +} + +# Retrieves and caches the command that implements "cget" for the +# specified option. +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name +# option The name of the option + +proc ::snit::RT.CacheCgetCommand {type selfns win self option} { + variable ${type}::Snit_optionInfo + variable ${selfns}::Snit_cgetCache + + if {[info exists Snit_optionInfo(islocal-$option)]} { + # We know the item; it's either local, or explicitly delegated. + if {$Snit_optionInfo(islocal-$option)} { + # It's a local option. If it has a cget method defined, + # use it; otherwise just return the value. + + if {$Snit_optionInfo(cget-$option) eq ""} { + set command [list set ${selfns}::options($option)] + } else { + # WHD: Snit 2.0 code -- simpler, no slower. + set command [list \ + $self \ + {*}$Snit_optionInfo(cget-$option) \ + $option] + } + + set Snit_cgetCache($option) $command + return $command + } + + # Explicitly delegated option; get target + set comp [lindex $Snit_optionInfo(target-$option) 0] + set target [lindex $Snit_optionInfo(target-$option) 1] + } elseif {$Snit_optionInfo(starcomp) ne "" && + [lsearch -exact $Snit_optionInfo(except) $option] == -1} { + # Unknown option, but unknowns are delegated; get target. + set comp $Snit_optionInfo(starcomp) + set target $option + } else { + return "" + } + + # Get the component's object. + set obj [RT.Component $type $selfns $comp] + + set command [list $obj cget $target] + set Snit_cgetCache($option) $command + + return $command +} + +# Implements the standard "configurelist" method +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name +# optionlist A list of options and their values. + +proc ::snit::RT.method.configurelist {type selfns win self optionlist} { + variable ${type}::Snit_optionInfo + + foreach {option value} $optionlist { + # FIRST, get the configure command, caching it if need be. + if {[catch {set ${selfns}::Snit_configureCache($option)} command]} { + set command [snit::RT.CacheConfigureCommand \ + $type $selfns $win $self $option] + + if {[llength $command] == 0} { + return -code error "unknown option \"$option\"" + } + } + + # NEXT, if we have a type-validation object, use it. + # TBD: Should test (islocal-$option) here, but islocal + # isn't defined for implicitly delegated options. + if {[info exists Snit_optionInfo(typeobj-$option)] + && $Snit_optionInfo(typeobj-$option) ne ""} { + if {[catch { + $Snit_optionInfo(typeobj-$option) validate $value + } result]} { + return -code error "invalid $option value: $result" + } + } + + # NEXT, the caching the configure command also cached the + # validate command, if any. If we have one, run it. + set valcommand [set ${selfns}::Snit_validateCache($option)] + + if {[llength $valcommand]} { + lappend valcommand $value + uplevel 1 $valcommand + } + + # NEXT, configure the option with the value. + lappend command $value + uplevel 1 $command + } + + return +} + +# Retrieves and caches the command that stores the named option. +# Also stores the command that validates the name option if any; +# If none, the validate command is "", so that the cache is always +# populated. +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name +# option An option name + +proc ::snit::RT.CacheConfigureCommand {type selfns win self option} { + variable ${type}::Snit_optionInfo + variable ${selfns}::Snit_configureCache + variable ${selfns}::Snit_validateCache + + if {[info exist Snit_optionInfo(islocal-$option)]} { + # We know the item; it's either local, or explicitly delegated. + + if {$Snit_optionInfo(islocal-$option)} { + # It's a local option. + + # If it's readonly, it throws an error if we're already + # constructed. + if {$Snit_optionInfo(readonly-$option)} { + if {[set ${selfns}::Snit_iinfo(constructed)]} { + error "option $option can only be set at instance creation" + } + } + + # If it has a validate method, cache that for later. + if {$Snit_optionInfo(validate-$option) ne ""} { + # WHD: Snit 2.0 code -- simpler, no slower. + set command [list \ + $self \ + {*}$Snit_optionInfo(validate-$option) \ + $option] + + set Snit_validateCache($option) $command + } else { + set Snit_validateCache($option) "" + } + + # If it has a configure method defined, + # cache it; otherwise, just set the value. + if {$Snit_optionInfo(configure-$option) eq ""} { + set command [list set ${selfns}::options($option)] + } else { + # WHD: Snit 2.0 code -- simpler, no slower. + set command [list \ + $self \ + {*}$Snit_optionInfo(configure-$option) \ + $option] + } + + set Snit_configureCache($option) $command + return $command + } + + # Delegated option: get target. + set comp [lindex $Snit_optionInfo(target-$option) 0] + set target [lindex $Snit_optionInfo(target-$option) 1] + } elseif {$Snit_optionInfo(starcomp) != "" && + [lsearch -exact $Snit_optionInfo(except) $option] == -1} { + # Unknown option, but unknowns are delegated. + set comp $Snit_optionInfo(starcomp) + set target $option + } else { + return "" + } + + # There is no validate command in this case; save an empty string. + set Snit_validateCache($option) "" + + # Get the component's object + set obj [RT.Component $type $selfns $comp] + + set command [list $obj configure $target] + set Snit_configureCache($option) $command + + return $command +} + +# Implements the standard "configure" method +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name +# args A list of options and their values, possibly empty. + +proc ::snit::RT.method.configure {type selfns win self args} { + # If two or more arguments, set values as usual. + if {[llength $args] >= 2} { + ::snit::RT.method.configurelist $type $selfns $win $self $args + return + } + + # If zero arguments, acquire data for each known option + # and return the list + if {[llength $args] == 0} { + set result {} + foreach opt [RT.method.info.options $type $selfns $win $self] { + # Refactor this, so that we don't need to call via $self. + lappend result [RT.GetOptionDbSpec \ + $type $selfns $win $self $opt] + } + + return $result + } + + # They want it for just one. + set opt [lindex $args 0] + + return [RT.GetOptionDbSpec $type $selfns $win $self $opt] +} + + +# Retrieves the option database spec for a single option. +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name +# option The name of an option +# +# TBD: This is a bad name. What it's returning is the +# result of the configure query. + +proc ::snit::RT.GetOptionDbSpec {type selfns win self opt} { + variable ${type}::Snit_optionInfo + + namespace upvar $selfns \ + Snit_components Snit_components \ + options options + + if {[info exists options($opt)]} { + # This is a locally-defined option. Just build the + # list and return it. + set res $Snit_optionInfo(resource-$opt) + set cls $Snit_optionInfo(class-$opt) + set def $Snit_optionInfo(default-$opt) + + return [list $opt $res $cls $def \ + [RT.method.cget $type $selfns $win $self $opt]] + } elseif {[info exists Snit_optionInfo(target-$opt)]} { + # This is an explicitly delegated option. The only + # thing we don't have is the default. + set res $Snit_optionInfo(resource-$opt) + set cls $Snit_optionInfo(class-$opt) + + # Get the default + set logicalName [lindex $Snit_optionInfo(target-$opt) 0] + set comp $Snit_components($logicalName) + set target [lindex $Snit_optionInfo(target-$opt) 1] + + if {[catch {$comp configure $target} result]} { + set defValue {} + } else { + set defValue [lindex $result 3] + } + + return [list $opt $res $cls $defValue [$self cget $opt]] + } elseif {$Snit_optionInfo(starcomp) ne "" && + [lsearch -exact $Snit_optionInfo(except) $opt] == -1} { + set logicalName $Snit_optionInfo(starcomp) + set target $opt + set comp $Snit_components($logicalName) + + if {[catch {set value [$comp cget $target]} result]} { + error "unknown option \"$opt\"" + } + + if {![catch {$comp configure $target} result]} { + # Replace the delegated option name with the local name. + return [::snit::Expand $result $target $opt] + } + + # configure didn't work; return simple form. + return [list $opt "" "" "" $value] + } else { + error "unknown option \"$opt\"" + } +} + +#----------------------------------------------------------------------- +# Type Introspection + +# Implements the standard "info" typemethod. +# +# type The snit type +# command The info subcommand +# args All other arguments. + +proc ::snit::RT.typemethod.info {type command args} { + global errorInfo + global errorCode + + switch -exact $command { + args - + body - + default - + typevars - + typemethods - + instances { + # TBD: it should be possible to delete this error + # handling. + set errflag [catch { + uplevel 1 [linsert $args 0 \ + ::snit::RT.typemethod.info.$command $type] + } result] + + if {$errflag} { + return -code error -errorinfo $errorInfo \ + -errorcode $errorCode $result + } else { + return $result + } + } + default { + error "\"$type info $command\" is not defined" + } + } +} + + +# Returns a list of the type's typevariables whose names match a +# pattern, excluding Snit internal variables. +# +# type A Snit type +# pattern Optional. The glob pattern to match. Defaults +# to *. + +proc ::snit::RT.typemethod.info.typevars {type {pattern *}} { + set result {} + foreach name [info vars "${type}::$pattern"] { + set tail [namespace tail $name] + if {![string match "Snit_*" $tail]} { + lappend result $name + } + } + + return $result +} + +# Returns a list of the type's methods whose names match a +# pattern. If "delegate typemethod *" is used, the list may +# not be complete. +# +# type A Snit type +# pattern Optional. The glob pattern to match. Defaults +# to *. + +proc ::snit::RT.typemethod.info.typemethods {type {pattern *}} { + variable ${type}::Snit_typemethodInfo + + # FIRST, get the explicit names, skipping prefixes. + set result {} + + foreach name [array names Snit_typemethodInfo -glob $pattern] { + if {[lindex $Snit_typemethodInfo($name) 0] != 1} { + lappend result $name + } + } + + # NEXT, add any from the cache that aren't explicit. + # WHD: fixed up to use newstyle method cache/list of subcommands. + if {[info exists Snit_typemethodInfo(*)]} { + # First, remove "*" from the list. + set ndx [lsearch -exact $result "*"] + if {$ndx != -1} { + set result [lreplace $result $ndx $ndx] + } + + # Next, get the type's -map + array set typemethodCache [namespace ensemble configure $type -map] + + # Next, get matching names from the cache that we don't already + # know about. + foreach name [array names typemethodCache -glob $pattern] { + if {[lsearch -exact $result $name] == -1} { + lappend result $name + } + } + } + + return $result +} + +# $type info args +# +# Returns a method's list of arguments. does not work for delegated +# methods, nor for the internal dispatch methods of multi-word +# methods. + +proc ::snit::RT.typemethod.info.args {type method} { + upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo + + # Snit_methodInfo: method -> list (flag cmd component) + + # flag : 1 -> internal dispatcher for multi-word method. + # 0 -> regular method + # + # cmd : template mapping from method to command prefix, may + # contain placeholders for various pieces of information. + # + # component : is empty for normal methods. + + #parray Snit_typemethodInfo + + if {![info exists Snit_typemethodInfo($method)]} { + return -code error "Unknown typemethod \"$method\"" + } + foreach {flag cmd component} $Snit_typemethodInfo($method) break + if {$flag} { + return -code error "Unknown typemethod \"$method\"" + } + if {$component != ""} { + return -code error "Delegated typemethod \"$method\"" + } + + set map [list %m $method %j [join $method _] %t $type] + set theproc [lindex [string map $map $cmd] 0] + return [lrange [::info args $theproc] 1 end] +} + +# $type info body +# +# Returns a method's body. does not work for delegated +# methods, nor for the internal dispatch methods of multi-word +# methods. + +proc ::snit::RT.typemethod.info.body {type method} { + upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo + + # Snit_methodInfo: method -> list (flag cmd component) + + # flag : 1 -> internal dispatcher for multi-word method. + # 0 -> regular method + # + # cmd : template mapping from method to command prefix, may + # contain placeholders for various pieces of information. + # + # component : is empty for normal methods. + + #parray Snit_typemethodInfo + + if {![info exists Snit_typemethodInfo($method)]} { + return -code error "Unknown typemethod \"$method\"" + } + foreach {flag cmd component} $Snit_typemethodInfo($method) break + if {$flag} { + return -code error "Unknown typemethod \"$method\"" + } + if {$component != ""} { + return -code error "Delegated typemethod \"$method\"" + } + + set map [list %m $method %j [join $method _] %t $type] + set theproc [lindex [string map $map $cmd] 0] + return [RT.body [::info body $theproc]] +} + +# $type info default +# +# Returns a method's list of arguments. does not work for delegated +# methods, nor for the internal dispatch methods of multi-word +# methods. + +proc ::snit::RT.typemethod.info.default {type method aname dvar} { + upvar 1 $dvar def + upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo + + # Snit_methodInfo: method -> list (flag cmd component) + + # flag : 1 -> internal dispatcher for multi-word method. + # 0 -> regular method + # + # cmd : template mapping from method to command prefix, may + # contain placeholders for various pieces of information. + # + # component : is empty for normal methods. + + #parray Snit_methodInfo + + if {![info exists Snit_typemethodInfo($method)]} { + return -code error "Unknown typemethod \"$method\"" + } + foreach {flag cmd component} $Snit_typemethodInfo($method) break + if {$flag} { + return -code error "Unknown typemethod \"$method\"" + } + if {$component != ""} { + return -code error "Delegated typemethod \"$method\"" + } + + set map [list %m $method %j [join $method _] %t $type] + set theproc [lindex [string map $map $cmd] 0] + return [::info default $theproc $aname def] +} + +# Returns a list of the type's instances whose names match +# a pattern. +# +# type A Snit type +# pattern Optional. The glob pattern to match +# Defaults to * +# +# REQUIRE: type is fully qualified. + +proc ::snit::RT.typemethod.info.instances {type {pattern *}} { + set result {} + + foreach selfns [namespace children $type "${type}::Snit_inst*"] { + namespace upvar $selfns Snit_instance instance + + if {[string match $pattern $instance]} { + lappend result $instance + } + } + + return $result +} + +#----------------------------------------------------------------------- +# Instance Introspection + +# Implements the standard "info" method. +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name +# command The info subcommand +# args All other arguments. + +proc ::snit::RT.method.info {type selfns win self command args} { + switch -exact $command { + args - + body - + default - + type - + vars - + options - + methods - + typevars - + typemethods { + set errflag [catch { + uplevel 1 [linsert $args 0 ::snit::RT.method.info.$command \ + $type $selfns $win $self] + } result] + + if {$errflag} { + global errorInfo + return -code error -errorinfo $errorInfo $result + } else { + return $result + } + } + default { + # error "\"$self info $command\" is not defined" + return -code error "\"$self info $command\" is not defined" + } + } +} + +# $self info type +# +# Returns the instance's type +proc ::snit::RT.method.info.type {type selfns win self} { + return $type +} + +# $self info typevars +# +# Returns the instance's type's typevariables +proc ::snit::RT.method.info.typevars {type selfns win self {pattern *}} { + return [RT.typemethod.info.typevars $type $pattern] +} + +# $self info typemethods +# +# Returns the instance's type's typemethods +proc ::snit::RT.method.info.typemethods {type selfns win self {pattern *}} { + return [RT.typemethod.info.typemethods $type $pattern] +} + +# Returns a list of the instance's methods whose names match a +# pattern. If "delegate method *" is used, the list may +# not be complete. +# +# type A Snit type +# selfns The instance namespace +# win The original instance name +# self The current instance name +# pattern Optional. The glob pattern to match. Defaults +# to *. + +proc ::snit::RT.method.info.methods {type selfns win self {pattern *}} { + variable ${type}::Snit_methodInfo + + # FIRST, get the explicit names, skipping prefixes. + set result {} + + foreach name [array names Snit_methodInfo -glob $pattern] { + if {[lindex $Snit_methodInfo($name) 0] != 1} { + lappend result $name + } + } + + # NEXT, add any from the cache that aren't explicit. + # WHD: Fixed up to use newstyle method cache/list of subcommands. + if {[info exists Snit_methodInfo(*)]} { + # First, remove "*" from the list. + set ndx [lsearch -exact $result "*"] + if {$ndx != -1} { + set result [lreplace $result $ndx $ndx] + } + + # Next, get the instance's -map + set self [set ${selfns}::Snit_instance] + + array set methodCache [namespace ensemble configure $self -map] + + # Next, get matching names from the cache that we don't already + # know about. + foreach name [array names methodCache -glob $pattern] { + if {[lsearch -exact $result $name] == -1} { + lappend result $name + } + } + } + + return $result +} + +# $self info args +# +# Returns a method's list of arguments. does not work for delegated +# methods, nor for the internal dispatch methods of multi-word +# methods. + +proc ::snit::RT.method.info.args {type selfns win self method} { + + upvar ${type}::Snit_methodInfo Snit_methodInfo + + # Snit_methodInfo: method -> list (flag cmd component) + + # flag : 1 -> internal dispatcher for multi-word method. + # 0 -> regular method + # + # cmd : template mapping from method to command prefix, may + # contain placeholders for various pieces of information. + # + # component : is empty for normal methods. + + #parray Snit_methodInfo + + if {![info exists Snit_methodInfo($method)]} { + return -code error "Unknown method \"$method\"" + } + foreach {flag cmd component} $Snit_methodInfo($method) break + if {$flag} { + return -code error "Unknown method \"$method\"" + } + if {$component != ""} { + return -code error "Delegated method \"$method\"" + } + + set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self] + set theproc [lindex [string map $map $cmd] 0] + return [lrange [::info args $theproc] 4 end] +} + +# $self info body +# +# Returns a method's body. does not work for delegated +# methods, nor for the internal dispatch methods of multi-word +# methods. + +proc ::snit::RT.method.info.body {type selfns win self method} { + + upvar ${type}::Snit_methodInfo Snit_methodInfo + + # Snit_methodInfo: method -> list (flag cmd component) + + # flag : 1 -> internal dispatcher for multi-word method. + # 0 -> regular method + # + # cmd : template mapping from method to command prefix, may + # contain placeholders for various pieces of information. + # + # component : is empty for normal methods. + + #parray Snit_methodInfo + + if {![info exists Snit_methodInfo($method)]} { + return -code error "Unknown method \"$method\"" + } + foreach {flag cmd component} $Snit_methodInfo($method) break + if {$flag} { + return -code error "Unknown method \"$method\"" + } + if {$component != ""} { + return -code error "Delegated method \"$method\"" + } + + set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self] + set theproc [lindex [string map $map $cmd] 0] + return [RT.body [::info body $theproc]] +} + +# $self info default +# +# Returns a method's list of arguments. does not work for delegated +# methods, nor for the internal dispatch methods of multi-word +# methods. + +proc ::snit::RT.method.info.default {type selfns win self method aname dvar} { + upvar 1 $dvar def + upvar ${type}::Snit_methodInfo Snit_methodInfo + + # Snit_methodInfo: method -> list (flag cmd component) + + # flag : 1 -> internal dispatcher for multi-word method. + # 0 -> regular method + # + # cmd : template mapping from method to command prefix, may + # contain placeholders for various pieces of information. + # + # component : is empty for normal methods. + + if {![info exists Snit_methodInfo($method)]} { + return -code error "Unknown method \"$method\"" + } + foreach {flag cmd component} $Snit_methodInfo($method) break + if {$flag} { + return -code error "Unknown method \"$method\"" + } + if {$component != ""} { + return -code error "Delegated method \"$method\"" + } + + set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self] + set theproc [lindex [string map $map $cmd] 0] + return [::info default $theproc $aname def] +} + +# $self info vars +# +# Returns the instance's instance variables +proc ::snit::RT.method.info.vars {type selfns win self {pattern *}} { + set result {} + foreach name [info vars "${selfns}::$pattern"] { + set tail [namespace tail $name] + if {![string match "Snit_*" $tail]} { + lappend result $name + } + } + + return $result +} + +# $self info options +# +# Returns a list of the names of the instance's options +proc ::snit::RT.method.info.options {type selfns win self {pattern *}} { + variable ${type}::Snit_optionInfo + + # First, get the local and explicitly delegated options + set result [concat $Snit_optionInfo(local) $Snit_optionInfo(delegated)] + + # If "configure" works as for Tk widgets, add the resulting + # options to the list. Skip excepted options + if {$Snit_optionInfo(starcomp) ne ""} { + namespace upvar $selfns Snit_components Snit_components + + set logicalName $Snit_optionInfo(starcomp) + set comp $Snit_components($logicalName) + + if {![catch {$comp configure} records]} { + foreach record $records { + set opt [lindex $record 0] + if {[lsearch -exact $result $opt] == -1 && + [lsearch -exact $Snit_optionInfo(except) $opt] == -1} { + lappend result $opt + } + } + } + } + + # Next, apply the pattern + set names {} + + foreach name $result { + if {[string match $pattern $name]} { + lappend names $name + } + } + + return $names +} + +proc ::snit::RT.body {body} { + regsub -all ".*# END snit method prolog\n" $body {} body + return $body +} diff --git a/src/bootsupport/lib/snit/pkgIndex.tcl b/src/bootsupport/lib/snit/pkgIndex.tcl new file mode 100644 index 00000000..a6624b25 --- /dev/null +++ b/src/bootsupport/lib/snit/pkgIndex.tcl @@ -0,0 +1,6 @@ +if {[package vsatisfies [package provide Tcl] 8.5 9]} { + package ifneeded snit 2.3.3 \ + [list source [file join $dir snit2.tcl]] +} + +package ifneeded snit 1.4.2 [list source [file join $dir snit.tcl]] diff --git a/src/bootsupport/lib/snit/snit.tcl b/src/bootsupport/lib/snit/snit.tcl new file mode 100644 index 00000000..20f6a40f --- /dev/null +++ b/src/bootsupport/lib/snit/snit.tcl @@ -0,0 +1,32 @@ +#----------------------------------------------------------------------- +# TITLE: +# snit.tcl +# +# AUTHOR: +# Will Duquette +# +# DESCRIPTION: +# Snit's Not Incr Tcl, a simple object system in Pure Tcl. +# +# Snit 1.x Loader +# +# Copyright (C) 2003-2006 by William H. Duquette +# This code is licensed as described in license.txt. +# +#----------------------------------------------------------------------- + +package require Tcl 8.5 9 + +# Define the snit namespace and save the library directory + +namespace eval ::snit:: { + set library [file dirname [info script]] +} + +source [file join $::snit::library main1.tcl] + +# Load the library of Snit validation types. + +source [file join $::snit::library validate.tcl] + +package provide snit 1.4.2 diff --git a/src/bootsupport/lib/snit/snit2.tcl b/src/bootsupport/lib/snit/snit2.tcl new file mode 100644 index 00000000..b7675a58 --- /dev/null +++ b/src/bootsupport/lib/snit/snit2.tcl @@ -0,0 +1,32 @@ +#----------------------------------------------------------------------- +# TITLE: +# snit2.tcl +# +# AUTHOR: +# Will Duquette +# +# DESCRIPTION: +# Snit's Not Incr Tcl, a simple object system in Pure Tcl. +# +# Snit 2.x Loader +# +# Copyright (C) 2003-2006 by William H. Duquette +# This code is licensed as described in license.txt. +# +#----------------------------------------------------------------------- + +package require Tcl 8.5 9 + +# Define the snit namespace and save the library directory + +namespace eval ::snit:: { + set library [file dirname [info script]] +} + +# Load the kernel. +source [file join $::snit::library main2.tcl] + +# Load the library of Snit validation types. +source [file join $::snit::library validate.tcl] + +package provide snit 2.3.3 diff --git a/src/bootsupport/lib/snit/validate.tcl b/src/bootsupport/lib/snit/validate.tcl new file mode 100644 index 00000000..4275e9be --- /dev/null +++ b/src/bootsupport/lib/snit/validate.tcl @@ -0,0 +1,720 @@ +#----------------------------------------------------------------------- +# TITLE: +# validate.tcl +# +# AUTHOR: +# Will Duquette +# +# DESCRIPTION: +# Snit validation types. +# +#----------------------------------------------------------------------- + +namespace eval ::snit:: { + namespace export \ + boolean \ + double \ + enum \ + fpixels \ + integer \ + listtype \ + pixels \ + stringtype \ + window +} + +#----------------------------------------------------------------------- +# snit::boolean + +snit::type ::snit::boolean { + #------------------------------------------------------------------- + # Type Methods + + typemethod validate {value} { + if {![string is boolean -strict $value]} { + return -code error -errorcode INVALID \ + "invalid boolean \"$value\", should be one of: 1, 0, true, false, yes, no, on, off" + + } + + return $value + } + + #------------------------------------------------------------------- + # Constructor + + # None needed; no options + + #------------------------------------------------------------------- + # Public Methods + + method validate {value} { + $type validate $value + } +} + +#----------------------------------------------------------------------- +# snit::double + +snit::type ::snit::double { + #------------------------------------------------------------------- + # Options + + # -min value + # + # Minimum value + + option -min -default "" -readonly 1 + + # -max value + # + # Maximum value + + option -max -default "" -readonly 1 + + #------------------------------------------------------------------- + # Type Methods + + typemethod validate {value} { + if {![string is double -strict $value]} { + return -code error -errorcode INVALID \ + "invalid value \"$value\", expected double" + } + + return $value + } + + #------------------------------------------------------------------- + # Constructor + + constructor {args} { + # FIRST, get the options + $self configurelist $args + + if {"" != $options(-min) && + ![string is double -strict $options(-min)]} { + return -code error \ + "invalid -min: \"$options(-min)\"" + } + + if {"" != $options(-max) && + ![string is double -strict $options(-max)]} { + return -code error \ + "invalid -max: \"$options(-max)\"" + } + + if {"" != $options(-min) && + "" != $options(-max) && + $options(-max) < $options(-min)} { + return -code error "-max < -min" + } + } + + #------------------------------------------------------------------- + # Public Methods + + # Fixed method for the snit::double type. + # WHD, 6/7/2010. + method validate {value} { + $type validate $value + + if {("" != $options(-min) && $value < $options(-min)) || + ("" != $options(-max) && $value > $options(-max))} { + + set msg "invalid value \"$value\", expected double" + + if {"" != $options(-min) && "" != $options(-max)} { + append msg " in range $options(-min), $options(-max)" + } elseif {"" != $options(-min)} { + append msg " no less than $options(-min)" + } elseif {"" != $options(-max)} { + append msg " no greater than $options(-max)" + } + + return -code error -errorcode INVALID $msg + } + + return $value + } +} + +#----------------------------------------------------------------------- +# snit::enum + +snit::type ::snit::enum { + #------------------------------------------------------------------- + # Options + + # -values list + # + # Valid values for this type + + option -values -default {} -readonly 1 + + #------------------------------------------------------------------- + # Type Methods + + typemethod validate {value} { + # No -values specified; it's always valid + return $value + } + + #------------------------------------------------------------------- + # Constructor + + constructor {args} { + $self configurelist $args + + if {[llength $options(-values)] == 0} { + return -code error \ + "invalid -values: \"\"" + } + } + + #------------------------------------------------------------------- + # Public Methods + + method validate {value} { + if {[lsearch -exact $options(-values) $value] == -1} { + return -code error -errorcode INVALID \ + "invalid value \"$value\", should be one of: [join $options(-values) {, }]" + } + + return $value + } +} + +#----------------------------------------------------------------------- +# snit::fpixels + +snit::type ::snit::fpixels { + #------------------------------------------------------------------- + # Options + + # -min value + # + # Minimum value + + option -min -default "" -readonly 1 + + # -max value + # + # Maximum value + + option -max -default "" -readonly 1 + + #------------------------------------------------------------------- + # Instance variables + + variable min "" ;# -min, no suffix + variable max "" ;# -max, no suffix + + #------------------------------------------------------------------- + # Type Methods + + typemethod validate {value} { + if {[catch {winfo fpixels . $value} dummy]} { + return -code error -errorcode INVALID \ + "invalid value \"$value\", expected fpixels" + } + + return $value + } + + #------------------------------------------------------------------- + # Constructor + + constructor {args} { + # FIRST, get the options + $self configurelist $args + + if {"" != $options(-min) && + [catch {winfo fpixels . $options(-min)} min]} { + return -code error \ + "invalid -min: \"$options(-min)\"" + } + + if {"" != $options(-max) && + [catch {winfo fpixels . $options(-max)} max]} { + return -code error \ + "invalid -max: \"$options(-max)\"" + } + + if {"" != $min && + "" != $max && + $max < $min} { + return -code error "-max < -min" + } + } + + #------------------------------------------------------------------- + # Public Methods + + method validate {value} { + $type validate $value + + set val [winfo fpixels . $value] + + if {("" != $min && $val < $min) || + ("" != $max && $val > $max)} { + + set msg "invalid value \"$value\", expected fpixels" + + if {"" != $min && "" != $max} { + append msg " in range $options(-min), $options(-max)" + } elseif {"" != $min} { + append msg " no less than $options(-min)" + } + + return -code error -errorcode INVALID $msg + } + + return $value + } +} + +#----------------------------------------------------------------------- +# snit::integer + +snit::type ::snit::integer { + #------------------------------------------------------------------- + # Options + + # -min value + # + # Minimum value + + option -min -default "" -readonly 1 + + # -max value + # + # Maximum value + + option -max -default "" -readonly 1 + + #------------------------------------------------------------------- + # Type Methods + + typemethod validate {value} { + if {![string is integer -strict $value]} { + return -code error -errorcode INVALID \ + "invalid value \"$value\", expected integer" + } + + return $value + } + + #------------------------------------------------------------------- + # Constructor + + constructor {args} { + # FIRST, get the options + $self configurelist $args + + if {"" != $options(-min) && + ![string is integer -strict $options(-min)]} { + return -code error \ + "invalid -min: \"$options(-min)\"" + } + + if {"" != $options(-max) && + ![string is integer -strict $options(-max)]} { + return -code error \ + "invalid -max: \"$options(-max)\"" + } + + if {"" != $options(-min) && + "" != $options(-max) && + $options(-max) < $options(-min)} { + return -code error "-max < -min" + } + } + + #------------------------------------------------------------------- + # Public Methods + + method validate {value} { + $type validate $value + + if {("" != $options(-min) && $value < $options(-min)) || + ("" != $options(-max) && $value > $options(-max))} { + + set msg "invalid value \"$value\", expected integer" + + if {"" != $options(-min) && "" != $options(-max)} { + append msg " in range $options(-min), $options(-max)" + } elseif {"" != $options(-min)} { + append msg " no less than $options(-min)" + } + + return -code error -errorcode INVALID $msg + } + + return $value + } +} + +#----------------------------------------------------------------------- +# snit::list + +snit::type ::snit::listtype { + #------------------------------------------------------------------- + # Options + + # -type type + # + # Specifies a value type + + option -type -readonly 1 + + # -minlen len + # + # Minimum list length + + option -minlen -readonly 1 -default 0 + + # -maxlen len + # + # Maximum list length + + option -maxlen -readonly 1 + + #------------------------------------------------------------------- + # Type Methods + + typemethod validate {value} { + if {[catch {llength $value} result]} { + return -code error -errorcode INVALID \ + "invalid value \"$value\", expected list" + } + + return $value + } + + #------------------------------------------------------------------- + # Constructor + + constructor {args} { + # FIRST, get the options + $self configurelist $args + + if {"" != $options(-minlen) && + (![string is integer -strict $options(-minlen)] || + $options(-minlen) < 0)} { + return -code error \ + "invalid -minlen: \"$options(-minlen)\"" + } + + if {"" == $options(-minlen)} { + set options(-minlen) 0 + } + + if {"" != $options(-maxlen) && + ![string is integer -strict $options(-maxlen)]} { + return -code error \ + "invalid -maxlen: \"$options(-maxlen)\"" + } + + if {"" != $options(-maxlen) && + $options(-maxlen) < $options(-minlen)} { + return -code error "-maxlen < -minlen" + } + } + + + #------------------------------------------------------------------- + # Methods + + method validate {value} { + $type validate $value + + set len [llength $value] + + if {$len < $options(-minlen)} { + return -code error -errorcode INVALID \ + "value has too few elements; at least $options(-minlen) expected" + } elseif {"" != $options(-maxlen)} { + if {$len > $options(-maxlen)} { + return -code error -errorcode INVALID \ + "value has too many elements; no more than $options(-maxlen) expected" + } + } + + # NEXT, check each value + if {"" != $options(-type)} { + foreach item $value { + set cmd $options(-type) + lappend cmd validate $item + uplevel \#0 $cmd + } + } + + return $value + } +} + +#----------------------------------------------------------------------- +# snit::pixels + +snit::type ::snit::pixels { + #------------------------------------------------------------------- + # Options + + # -min value + # + # Minimum value + + option -min -default "" -readonly 1 + + # -max value + # + # Maximum value + + option -max -default "" -readonly 1 + + #------------------------------------------------------------------- + # Instance variables + + variable min "" ;# -min, no suffix + variable max "" ;# -max, no suffix + + #------------------------------------------------------------------- + # Type Methods + + typemethod validate {value} { + if {[catch {winfo pixels . $value} dummy]} { + return -code error -errorcode INVALID \ + "invalid value \"$value\", expected pixels" + } + + return $value + } + + #------------------------------------------------------------------- + # Constructor + + constructor {args} { + # FIRST, get the options + $self configurelist $args + + if {"" != $options(-min) && + [catch {winfo pixels . $options(-min)} min]} { + return -code error \ + "invalid -min: \"$options(-min)\"" + } + + if {"" != $options(-max) && + [catch {winfo pixels . $options(-max)} max]} { + return -code error \ + "invalid -max: \"$options(-max)\"" + } + + if {"" != $min && + "" != $max && + $max < $min} { + return -code error "-max < -min" + } + } + + #------------------------------------------------------------------- + # Public Methods + + method validate {value} { + $type validate $value + + set val [winfo pixels . $value] + + if {("" != $min && $val < $min) || + ("" != $max && $val > $max)} { + + set msg "invalid value \"$value\", expected pixels" + + if {"" != $min && "" != $max} { + append msg " in range $options(-min), $options(-max)" + } elseif {"" != $min} { + append msg " no less than $options(-min)" + } + + return -code error -errorcode INVALID $msg + } + + return $value + } +} + +#----------------------------------------------------------------------- +# snit::stringtype + +snit::type ::snit::stringtype { + #------------------------------------------------------------------- + # Options + + # -minlen len + # + # Minimum list length + + option -minlen -readonly 1 -default 0 + + # -maxlen len + # + # Maximum list length + + option -maxlen -readonly 1 + + # -nocase 0|1 + # + # globs and regexps are case-insensitive if -nocase 1. + + option -nocase -readonly 1 -default 0 + + # -glob pattern + # + # Glob-match pattern, or "" + + option -glob -readonly 1 + + # -regexp regexp + # + # Regular expression to match + + option -regexp -readonly 1 + + #------------------------------------------------------------------- + # Type Methods + + typemethod validate {value} { + # By default, any string (hence, any Tcl value) is valid. + return $value + } + + #------------------------------------------------------------------- + # Constructor + + constructor {args} { + # FIRST, get the options + $self configurelist $args + + # NEXT, validate -minlen and -maxlen + if {"" != $options(-minlen) && + (![string is integer -strict $options(-minlen)] || + $options(-minlen) < 0)} { + return -code error \ + "invalid -minlen: \"$options(-minlen)\"" + } + + if {"" == $options(-minlen)} { + set options(-minlen) 0 + } + + if {"" != $options(-maxlen) && + ![string is integer -strict $options(-maxlen)]} { + return -code error \ + "invalid -maxlen: \"$options(-maxlen)\"" + } + + if {"" != $options(-maxlen) && + $options(-maxlen) < $options(-minlen)} { + return -code error "-maxlen < -minlen" + } + + # NEXT, validate -nocase + if {[catch {snit::boolean validate $options(-nocase)} result]} { + return -code error "invalid -nocase: $result" + } + + # Validate the glob + if {"" != $options(-glob) && + [catch {string match $options(-glob) ""} dummy]} { + return -code error \ + "invalid -glob: \"$options(-glob)\"" + } + + # Validate the regexp + if {"" != $options(-regexp) && + [catch {regexp $options(-regexp) ""} dummy]} { + return -code error \ + "invalid -regexp: \"$options(-regexp)\"" + } + } + + + #------------------------------------------------------------------- + # Methods + + method validate {value} { + # Usually we'd call [$type validate $value] here, but + # as it's a no-op, don't bother. + + # FIRST, validate the length. + set len [string length $value] + + if {$len < $options(-minlen)} { + return -code error -errorcode INVALID \ + "too short: at least $options(-minlen) characters expected" + } elseif {"" != $options(-maxlen)} { + if {$len > $options(-maxlen)} { + return -code error -errorcode INVALID \ + "too long: no more than $options(-maxlen) characters expected" + } + } + + # NEXT, check the glob match, with or without case. + if {"" != $options(-glob)} { + if {$options(-nocase)} { + set result [string match -nocase $options(-glob) $value] + } else { + set result [string match $options(-glob) $value] + } + + if {!$result} { + return -code error -errorcode INVALID \ + "invalid value \"$value\"" + } + } + + # NEXT, check regexp match with or without case + if {"" != $options(-regexp)} { + if {$options(-nocase)} { + set result [regexp -nocase -- $options(-regexp) $value] + } else { + set result [regexp -- $options(-regexp) $value] + } + + if {!$result} { + return -code error -errorcode INVALID \ + "invalid value \"$value\"" + } + } + + return $value + } +} + +#----------------------------------------------------------------------- +# snit::window + +snit::type ::snit::window { + #------------------------------------------------------------------- + # Type Methods + + typemethod validate {value} { + if {![winfo exists $value]} { + return -code error -errorcode INVALID \ + "invalid value \"$value\", value is not a window" + } + + return $value + } + + #------------------------------------------------------------------- + # Constructor + + # None needed; no options + + #------------------------------------------------------------------- + # Public Methods + + method validate {value} { + $type validate $value + } +} diff --git a/src/bootsupport/lib/struct/disjointset.tcl b/src/bootsupport/lib/struct/disjointset.tcl index 84a59a21..677fa66d 100644 --- a/src/bootsupport/lib/struct/disjointset.tcl +++ b/src/bootsupport/lib/struct/disjointset.tcl @@ -17,7 +17,7 @@ # - https://dl.acm.org/citation.cfm?doid=364099.364331 # -package require Tcl 8.6 +package require Tcl 8.6 9 # Initialize the disjointset structure namespace. Note that any # missing parent namespace (::struct) will be automatically created as @@ -381,5 +381,5 @@ namespace eval ::struct { namespace export disjointset } -package provide struct::disjointset 1.1 +package provide struct::disjointset 1.2 return diff --git a/src/bootsupport/lib/struct/graph.tcl b/src/bootsupport/lib/struct/graph.tcl index 19663fd3..d2de11c5 100644 --- a/src/bootsupport/lib/struct/graph.tcl +++ b/src/bootsupport/lib/struct/graph.tcl @@ -9,7 +9,7 @@ # @mdgen EXCLUDE: graph_c.tcl -package require Tcl 8.4 +package require Tcl 8.5 9 namespace eval ::struct::graph {} @@ -33,7 +33,6 @@ proc ::struct::graph::LoadAccelerator {key} { switch -exact -- $key { critcl { # Critcl implementation of graph requires Tcl 8.4. - if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} if {[catch {package require tcllibc}]} {return 0} set r [llength [info commands ::struct::graph_critcl]] } @@ -175,4 +174,4 @@ namespace eval ::struct { namespace export graph } -package provide struct::graph 2.4.3 +package provide struct::graph 2.4.4 diff --git a/src/bootsupport/lib/struct/graph1.tcl b/src/bootsupport/lib/struct/graph1.tcl index 80c24592..a81ed014 100644 --- a/src/bootsupport/lib/struct/graph1.tcl +++ b/src/bootsupport/lib/struct/graph1.tcl @@ -2151,4 +2151,4 @@ namespace eval ::struct { namespace import -force graph::graph namespace export graph } -package provide struct::graph 1.2.1 +package provide struct::graph 1.2.2 diff --git a/src/bootsupport/lib/struct/graph_c.tcl b/src/bootsupport/lib/struct/graph_c.tcl index 56493b32..98d608e8 100644 --- a/src/bootsupport/lib/struct/graph_c.tcl +++ b/src/bootsupport/lib/struct/graph_c.tcl @@ -11,8 +11,8 @@ package require critcl # @sak notprovided struct_graphc -package provide struct_graphc 2.4.3 -package require Tcl 8.2 +package provide struct_graphc 2.4.4 +package require Tcl 8.5 9 namespace eval ::struct { # Supporting code for the main command. @@ -55,7 +55,7 @@ namespace eval ::struct { Tcl_CmdInfo ci; if ((objc != 4) && (objc != 2) && (objc != 1)) { - Tcl_WrongNumArgs (interp, 1, objv, USAGE); + Tcl_WrongNumArgs (interp, 1, objv, USAGE); /* OK tcl9 */ return TCL_ERROR; } @@ -74,11 +74,11 @@ namespace eval ::struct { Tcl_IncrRefCount (fqn); if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) { - Tcl_AppendToObj (fqn, "::", -1); + Tcl_AppendToObj (fqn, "::", -1); /* OK tcl9 */ } - Tcl_AppendToObj (fqn, name, -1); + Tcl_AppendToObj (fqn, name, -1); /* OK tcl9 */ } else { - fqn = Tcl_NewStringObj (name, -1); + fqn = Tcl_NewStringObj (name, -1); /* OK tcl9 */ Tcl_IncrRefCount (fqn); } @@ -88,9 +88,9 @@ namespace eval ::struct { Tcl_Obj* err; err = Tcl_NewObj (); - Tcl_AppendToObj (err, "command \"", -1); + Tcl_AppendToObj (err, "command \"", -1); /* OK tcl9 */ Tcl_AppendObjToObj (err, fqn); - Tcl_AppendToObj (err, "\" already exists, unable to create graph", -1); + Tcl_AppendToObj (err, "\" already exists, unable to create graph", -1); /* OK tcl9 */ Tcl_DecrRefCount (fqn); Tcl_SetObjResult (interp, err); @@ -115,7 +115,7 @@ namespace eval ::struct { if (Tcl_GetIndexFromObj (interp, type, types, "type", 0, &srctype) != TCL_OK) { Tcl_DecrRefCount (fqn); Tcl_ResetResult (interp); - Tcl_WrongNumArgs (interp, 1, objv, USAGE); + Tcl_WrongNumArgs (interp, 1, objv, USAGE); /* OK tcl9 */ return TCL_ERROR; } @@ -144,9 +144,9 @@ namespace eval ::struct { g = g_new (); } - g->cmd = Tcl_CreateObjCommand (interp, Tcl_GetString (fqn), - g_objcmd, (ClientData) g, - gg_delete); + g->cmd = Tcl_CreateObjCommand2 (interp, Tcl_GetString (fqn), + g_objcmd, (ClientData) g, + gg_delete); Tcl_SetObjResult (interp, fqn); Tcl_DecrRefCount (fqn); diff --git a/src/bootsupport/lib/struct/graph_tcl.tcl b/src/bootsupport/lib/struct/graph_tcl.tcl index a63fd548..c780a7d0 100644 --- a/src/bootsupport/lib/struct/graph_tcl.tcl +++ b/src/bootsupport/lib/struct/graph_tcl.tcl @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require Tcl 8.4 +package require Tcl 8.5 9 package require struct::list package require struct::set diff --git a/src/bootsupport/lib/struct/graphops.tcl b/src/bootsupport/lib/struct/graphops.tcl index 91ec450d..b5cb9673 100644 --- a/src/bootsupport/lib/struct/graphops.tcl +++ b/src/bootsupport/lib/struct/graphops.tcl @@ -13,7 +13,7 @@ # ### ### ### ######### ######### ######### ## Requisites -package require Tcl 8.6 +package require Tcl 8.6 9 package require struct::disjointset ; # Used by kruskal -- 8.6 required package require struct::prioqueue ; # Used by kruskal, prim @@ -3784,4 +3784,4 @@ namespace eval ::struct::graph::op { #namespace export ... } -package provide struct::graph::op 0.11.3 +package provide struct::graph::op 0.11.4 diff --git a/src/bootsupport/lib/struct/list.tcl b/src/bootsupport/lib/struct/list.tcl index e0f738db..d20fa92e 100644 --- a/src/bootsupport/lib/struct/list.tcl +++ b/src/bootsupport/lib/struct/list.tcl @@ -13,7 +13,7 @@ # #---------------------------------------------------------------------- -package require Tcl 8.4 +package require Tcl 8.5 9 package require cmdline namespace eval ::struct { namespace eval list {} } @@ -1831,4 +1831,4 @@ namespace eval ::struct { namespace import -force list::list namespace export list } -package provide struct::list 1.8.5 +package provide struct::list 1.8.6 diff --git a/src/bootsupport/lib/struct/list.test.tcl b/src/bootsupport/lib/struct/list.test.tcl index ae0403a9..924c3108 100644 --- a/src/bootsupport/lib/struct/list.test.tcl +++ b/src/bootsupport/lib/struct/list.test.tcl @@ -330,7 +330,7 @@ proc ::struct::list::test::main {} { # In 8.6+ assign is the native lassign and it does nothing gracefully, # per TIP 323, making assign-4.4 not an error anymore. - test assign-4.4 {assign method} {!tcl8.6plus} { + test assign-4.4 {assign method} tcl8.5only { catch {assign {foo bar}} msg ; set msg } $err @@ -630,40 +630,20 @@ proc ::struct::list::test::main {} { interp alias {} repeat {} ::struct::list::list repeat - if {[package vcompare [package provide Tcl] 8.5] < 0} { - # 8.4 - set err [tcltest::wrongNumArgs {::struct::list::Lrepeat} {positiveCount value args} 0] - } elseif {![package vsatisfies [package provide Tcl] 8.6]} { - # 8.5+ - #set err [tcltest::wrongNumArgs {lrepeat} {positiveCount value ?value ...?} 0] - set err [tcltest::wrongNumArgs {::struct::list::Lrepeat} {positiveCount value ?value ...?} 0] - } else { - # 8.6+ - set err [tcltest::wrongNumArgs {::struct::list::Lrepeat} {count ?value ...?} 1] - } test repeat-4.1 {repeat command} { catch {repeat} msg set msg - } $err + } [tcltest::byConstraint [list \ + tcl8.6plus [tcltest::wrongNumArgs {::struct::list::Lrepeat} {count ?value ...?} 1] \ + tcl8.5only [tcltest::wrongNumArgs {::struct::list::Lrepeat} {positiveCount value ?value ...?} 0]]] - if {[package vcompare [package provide Tcl] 8.5] < 0} { - # 8.4 - set err [tcltest::wrongNumArgs {::struct::list::Lrepeat} {positiveCount value args} 1] - } elseif {![package vsatisfies [package provide Tcl] 8.6]} { - # 8.5+ - #set err [tcltest::wrongNumArgs {lrepeat} {positiveCount value ?value ...?} 1] - set err [tcltest::wrongNumArgs {::struct::list::Lrepeat} {positiveCount value ?value ...?} 1] - } else { - # 8.6+ - set err [tcltest::wrongNumArgs {::struct::list::Lrepeat} {count ?value ...?} 1] - } # In 8.6+ repeat is the native lrepeat and it does nothing gracefully, # per TIP 323, making repeat-4.2 not an error anymore. - test repeat-4.2 {repeat command} {!tcl8.6plus} { + test repeat-4.2 {repeat command} tcl8.5only { catch {repeat a} msg set msg - } $err + } [tcltest::wrongNumArgs {::struct::list::Lrepeat} {positiveCount value ?value ...?} 1] test repeat-4.3 {repeat command} { catch {repeat a b} msg @@ -672,22 +652,18 @@ proc ::struct::list::test::main {} { # In 8.6+ repeat is the native lrepeat and it does nothing gracefully, # per TIP 323, making repeat-4.2 not an error anymore. - test repeat-4.4 {repeat command} {!tcl8.6plus} { + test repeat-4.4 {repeat command} tcl8.5only { catch {repeat 0 b} msg set msg } {must have a count of at least 1} - if {![package vsatisfies [package provide Tcl] 8.6]} { - # before 8.6 - set err {must have a count of at least 1} - } else { - # 8.6+, native lrepeat changed error message. - set err {bad count "-1": must be integer >= 0} - } test repeat-4.5 {repeat command} { catch {repeat -1 b} msg set msg - } $err + } [tcltest::byConstraint { + tcl8.6plus {bad count "-1": must be integer >= 0} + tcl8.5only {must have a count of at least 1} + }] test repeat-4.6 {repeat command} { repeat 1 b c @@ -1289,4 +1265,4 @@ proc ::struct::list::test::main {} { } } -package provide struct::list::test 1.8.4 +package provide struct::list::test 1.8.5 diff --git a/src/bootsupport/lib/struct/map.tcl b/src/bootsupport/lib/struct/map.tcl index 41094def..bd31a158 100644 --- a/src/bootsupport/lib/struct/map.tcl +++ b/src/bootsupport/lib/struct/map.tcl @@ -13,7 +13,7 @@ # ### ### ### ######### ######### ######### ## Requisites -package require Tcl 8.4 +package require Tcl 8.5 9 package require snit # ### ### ### ######### ######### ######### @@ -100,5 +100,5 @@ snit::type ::struct::map::I { # ### ### ### ######### ######### ######### ## Ready -package provide struct::map 1 +package provide struct::map 1.1 return diff --git a/src/bootsupport/lib/struct/matrix.tcl b/src/bootsupport/lib/struct/matrix.tcl index ee098eae..a8284015 100644 --- a/src/bootsupport/lib/struct/matrix.tcl +++ b/src/bootsupport/lib/struct/matrix.tcl @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require Tcl 8.5 +package require Tcl 8.5 9 package require textutil::wcswidth ;# TermWidth, for _columnwidth and related places namespace eval ::struct {} @@ -1605,8 +1605,8 @@ proc ::struct::matrix::_link {name args} { } } - trace variable array wu [list ::struct::matrix::MatTraceIn $variable $name] - trace variable data w [list ::struct::matrix::MatTraceOut $variable $name] + trace add variable array {write unset} [list ::struct::matrix::MatTraceIn $variable $name] + trace add variable data write [list ::struct::matrix::MatTraceOut $variable $name] return } @@ -2212,8 +2212,8 @@ proc ::struct::matrix::_unlink {name avar} { upvar #0 $avar array variable ${name}::data - trace vdelete array wu [list ::struct::matrix::MatTraceIn $avar $name] - trace vdelete date w [list ::struct::matrix::MatTraceOut $avar $name] + trace remove variable array {write unset} [list ::struct::matrix::MatTraceIn $avar $name] + trace remove variable data write [list ::struct::matrix::MatTraceOut $avar $name] unset link($avar) return @@ -2485,7 +2485,7 @@ proc ::struct::matrix::MatTraceIn {avar name var idx op} { # 2. An individual element was unset: Set the corresponding cell to the empty string. # See SF Tcllib Bug #532791. - if {(![string compare $op u]) && ($idx == {})} { + if {(![string compare $op unset]) && ($idx == {})} { # Possibility 1: Array was destroyed $name unlink $avar return @@ -2505,7 +2505,7 @@ proc ::struct::matrix::MatTraceIn {avar name var idx op} { # Use standard method to propagate the change. # => Get automatically index checks, cache updates, ... - if {![string compare $op u]} { + if {![string compare $op unset]} { # Unset possibility 2: Element was unset. # Note: Setting the cell to the empty string will # invoke MatTraceOut for this array and thus try @@ -2803,4 +2803,4 @@ namespace eval ::struct { namespace import -force matrix::matrix namespace export matrix } -package provide struct::matrix 2.1 +package provide struct::matrix 2.2 diff --git a/src/bootsupport/lib/struct/pkgIndex.tcl b/src/bootsupport/lib/struct/pkgIndex.tcl index a76d377b..001cf324 100644 --- a/src/bootsupport/lib/struct/pkgIndex.tcl +++ b/src/bootsupport/lib/struct/pkgIndex.tcl @@ -1,29 +1,25 @@ -if {![package vsatisfies [package provide Tcl] 8.2]} {return} -package ifneeded struct 2.1 [list source [file join $dir struct.tcl]] -package ifneeded struct 1.4 [list source [file join $dir struct1.tcl]] +if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} +package ifneeded struct 2.2 [list source [file join $dir struct.tcl]] +package ifneeded struct 1.5 [list source [file join $dir struct1.tcl]] -package ifneeded struct::queue 1.4.5 [list source [file join $dir queue.tcl]] -package ifneeded struct::stack 1.5.3 [list source [file join $dir stack.tcl]] -package ifneeded struct::tree 2.1.2 [list source [file join $dir tree.tcl]] -package ifneeded struct::pool 1.2.3 [list source [file join $dir pool.tcl]] -package ifneeded struct::record 1.2.2 [list source [file join $dir record.tcl]] -package ifneeded struct::set 2.2.3 [list source [file join $dir sets.tcl]] -package ifneeded struct::prioqueue 1.4 [list source [file join $dir prioqueue.tcl]] -package ifneeded struct::skiplist 1.3 [list source [file join $dir skiplist.tcl]] +package ifneeded struct::queue 1.4.6 [list source [file join $dir queue.tcl]] +package ifneeded struct::stack 1.5.4 [list source [file join $dir stack.tcl]] +package ifneeded struct::tree 2.1.3 [list source [file join $dir tree.tcl]] +package ifneeded struct::pool 1.2.4 [list source [file join $dir pool.tcl]] +package ifneeded struct::record 1.2.3 [list source [file join $dir record.tcl]] +package ifneeded struct::set 2.2.4 [list source [file join $dir sets.tcl]] +package ifneeded struct::prioqueue 1.5 [list source [file join $dir prioqueue.tcl]] +package ifneeded struct::skiplist 1.4 [list source [file join $dir skiplist.tcl]] -package ifneeded struct::graph 1.2.1 [list source [file join $dir graph1.tcl]] -package ifneeded struct::tree 1.2.2 [list source [file join $dir tree1.tcl]] +package ifneeded struct::graph 1.2.2 [list source [file join $dir graph1.tcl]] +package ifneeded struct::tree 1.2.3 [list source [file join $dir tree1.tcl]] -if {![package vsatisfies [package provide Tcl] 8.4]} {return} -package ifneeded struct::list 1.8.5 [list source [file join $dir list.tcl]] -package ifneeded struct::list::test 1.8.4 [list source [file join $dir list.test.tcl]] -package ifneeded struct::graph 2.4.3 [list source [file join $dir graph.tcl]] -package ifneeded struct::map 1 [list source [file join $dir map.tcl]] +package ifneeded struct::list 1.8.6 [list source [file join $dir list.tcl]] +package ifneeded struct::list::test 1.8.5 [list source [file join $dir list.test.tcl]] +package ifneeded struct::graph 2.4.4 [list source [file join $dir graph.tcl]] +package ifneeded struct::map 1.1 [list source [file join $dir map.tcl]] -if {![package vsatisfies [package provide Tcl] 8.5]} {return} +package ifneeded struct::matrix 2.2 [list source [file join $dir matrix.tcl]] -package ifneeded struct::matrix 2.1 [list source [file join $dir matrix.tcl]] - -if {![package vsatisfies [package provide Tcl] 8.6]} {return} -package ifneeded struct::disjointset 1.1 [list source [file join $dir disjointset.tcl]] -package ifneeded struct::graph::op 0.11.3 [list source [file join $dir graphops.tcl]] +package ifneeded struct::disjointset 1.2 [list source [file join $dir disjointset.tcl]] +package ifneeded struct::graph::op 0.11.4 [list source [file join $dir graphops.tcl]] diff --git a/src/bootsupport/lib/struct/pool.tcl b/src/bootsupport/lib/struct/pool.tcl index e2557cec..1d14768c 100644 --- a/src/bootsupport/lib/struct/pool.tcl +++ b/src/bootsupport/lib/struct/pool.tcl @@ -59,7 +59,7 @@ namespace eval ::struct::pool { # A small helper routine to generate structured errors -if {[package vsatisfies [package present Tcl] 8.5]} { +if {[package vsatisfies [package present Tcl] 8.5 9]} { # Tcl 8.5+, have expansion operator and syntax. And option -level. proc ::struct::pool::Error {error args} { variable Errors @@ -712,4 +712,4 @@ namespace eval ::struct { namespace import -force pool::pool namespace export pool } -package provide struct::pool 1.2.3 +package provide struct::pool 1.2.4 diff --git a/src/bootsupport/lib/struct/prioqueue.tcl b/src/bootsupport/lib/struct/prioqueue.tcl index 44f657d6..b47feafb 100644 --- a/src/bootsupport/lib/struct/prioqueue.tcl +++ b/src/bootsupport/lib/struct/prioqueue.tcl @@ -11,7 +11,7 @@ # # RCS: @(#) $Id: prioqueue.tcl,v 1.10 2008/09/04 04:35:02 andreas_kupries Exp $ -package require Tcl 8.2 +package require Tcl 8.5 9 namespace eval ::struct {} @@ -532,4 +532,4 @@ namespace eval ::struct { namespace export prioqueue } -package provide struct::prioqueue 1.4 +package provide struct::prioqueue 1.5 diff --git a/src/bootsupport/lib/struct/queue.tcl b/src/bootsupport/lib/struct/queue.tcl index 7f5dcd91..4db75306 100644 --- a/src/bootsupport/lib/struct/queue.tcl +++ b/src/bootsupport/lib/struct/queue.tcl @@ -12,7 +12,7 @@ # @mdgen EXCLUDE: queue_c.tcl -package require Tcl 8.4 +package require Tcl 8.5 9 namespace eval ::struct::queue {} # ### ### ### ######### ######### ######### @@ -35,16 +35,12 @@ proc ::struct::queue::LoadAccelerator {key} { switch -exact -- $key { critcl { # Critcl implementation of queue requires Tcl 8.4. - if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} if {[catch {package require tcllibc}]} {return 0} set r [llength [info commands ::struct::queue_critcl]] } tcl { variable selfdir - if { - [package vsatisfies [package provide Tcl] 8.5] && - ![catch {package require TclOO 0.6.1-}] - } { + if {![catch {package require TclOO 0.6.1-}]} { source [file join $selfdir queue_oo.tcl] } else { source [file join $selfdir queue_tcl.tcl] @@ -184,4 +180,4 @@ namespace eval ::struct { namespace export queue } -package provide struct::queue 1.4.5 +package provide struct::queue 1.4.6 diff --git a/src/bootsupport/lib/struct/queue_c.tcl b/src/bootsupport/lib/struct/queue_c.tcl index 30b1aec6..6d9fb70b 100644 --- a/src/bootsupport/lib/struct/queue_c.tcl +++ b/src/bootsupport/lib/struct/queue_c.tcl @@ -14,7 +14,7 @@ package require critcl # @sak notprovided struct_queuec package provide struct_queuec 1.3.1 -package require Tcl 8.4 +package require Tcl 8.5 9 namespace eval ::struct { # Supporting code for the main command. @@ -93,7 +93,7 @@ namespace eval ::struct { #define USAGE "?name?" if ((objc != 2) && (objc != 1)) { - Tcl_WrongNumArgs (interp, 1, objv, USAGE); + Tcl_WrongNumArgs (interp, 1, objv, USAGE); /* OK tcl9 */ return TCL_ERROR; } @@ -112,11 +112,11 @@ namespace eval ::struct { Tcl_IncrRefCount (fqn); if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) { - Tcl_AppendToObj (fqn, "::", -1); + Tcl_AppendToObj (fqn, "::", -1); /* OK tcl9 */ } - Tcl_AppendToObj (fqn, name, -1); + Tcl_AppendToObj (fqn, name, -1); /* OK tcl9 */ } else { - fqn = Tcl_NewStringObj (name, -1); + fqn = Tcl_NewStringObj (name, -1); /* OK tcl9 */ Tcl_IncrRefCount (fqn); } Tcl_ResetResult (interp); @@ -127,9 +127,9 @@ namespace eval ::struct { Tcl_Obj* err; err = Tcl_NewObj (); - Tcl_AppendToObj (err, "command \"", -1); + Tcl_AppendToObj (err, "command \"", -1); /* OK tcl9 */ Tcl_AppendObjToObj (err, fqn); - Tcl_AppendToObj (err, "\" already exists, unable to create queue", -1); + Tcl_AppendToObj (err, "\" already exists, unable to create queue", -1); /* OK tcl9 */ Tcl_DecrRefCount (fqn); Tcl_SetObjResult (interp, err); @@ -137,9 +137,9 @@ namespace eval ::struct { } qd = qu_new(); - qd->cmd = Tcl_CreateObjCommand (interp, Tcl_GetString (fqn), - qums_objcmd, (ClientData) qd, - QDdeleteCmd); + qd->cmd = Tcl_CreateObjCommand2 (interp, Tcl_GetString (fqn), + qums_objcmd, (ClientData) qd, + QDdeleteCmd); Tcl_SetObjResult (interp, fqn); Tcl_DecrRefCount (fqn); diff --git a/src/bootsupport/lib/struct/queue_oo.tcl b/src/bootsupport/lib/struct/queue_oo.tcl index e6e1fe73..c5de5dd4 100644 --- a/src/bootsupport/lib/struct/queue_oo.tcl +++ b/src/bootsupport/lib/struct/queue_oo.tcl @@ -10,7 +10,7 @@ # # RCS: @(#) $Id: queue_oo.tcl,v 1.2 2010/09/10 17:31:04 andreas_kupries Exp $ -package require Tcl 8.5 +package require Tcl 8.5 9 package require TclOO 0.6.1- ; # This includes 1 and higher. # Cleanup first diff --git a/src/bootsupport/lib/struct/queue_tcl.tcl b/src/bootsupport/lib/struct/queue_tcl.tcl index 78f93bd5..9897a62f 100644 --- a/src/bootsupport/lib/struct/queue_tcl.tcl +++ b/src/bootsupport/lib/struct/queue_tcl.tcl @@ -92,7 +92,7 @@ proc ::struct::queue::queue_tcl {args} { # Results: # Varies based on command to perform -if {[package vsatisfies [package provide Tcl] 8.5]} { +if {[package vsatisfies [package provide Tcl] 8.5 9]} { # In 8.5+ we can do an ensemble for fast dispatch. proc ::struct::queue::QueueProc {name cmd args} { diff --git a/src/bootsupport/lib/struct/record.tcl b/src/bootsupport/lib/struct/record.tcl index 6c58dd78..20bd073d 100644 --- a/src/bootsupport/lib/struct/record.tcl +++ b/src/bootsupport/lib/struct/record.tcl @@ -826,5 +826,5 @@ namespace eval ::struct { namespace export record } -package provide struct::record 1.2.2 +package provide struct::record 1.2.3 return diff --git a/src/bootsupport/lib/struct/sets.tcl b/src/bootsupport/lib/struct/sets.tcl index 88316377..f6fdd0d4 100644 --- a/src/bootsupport/lib/struct/sets.tcl +++ b/src/bootsupport/lib/struct/sets.tcl @@ -15,7 +15,7 @@ # @mdgen EXCLUDE: sets_c.tcl -package require Tcl 8.2 +package require Tcl 8.5 9 namespace eval ::struct::set {} @@ -38,8 +38,6 @@ proc ::struct::set::LoadAccelerator {key} { set r 0 switch -exact -- $key { critcl { - # Critcl implementation of set requires Tcl 8.4. - if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} if {[catch {package require tcllibc}]} {return 0} set r [llength [info commands ::struct::set_critcl]] } @@ -186,4 +184,4 @@ namespace eval ::struct { namespace export set } -package provide struct::set 2.2.3 +package provide struct::set 2.2.4 diff --git a/src/bootsupport/lib/struct/sets_c.tcl b/src/bootsupport/lib/struct/sets_c.tcl index cd07f925..9c4fb76c 100644 --- a/src/bootsupport/lib/struct/sets_c.tcl +++ b/src/bootsupport/lib/struct/sets_c.tcl @@ -9,14 +9,12 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: sets_c.tcl,v 1.3 2008/03/25 07:15:34 andreas_kupries Exp $ -# #---------------------------------------------------------------------- package require critcl # @sak notprovided struct_setc package provide struct_setc 2.1.1 -package require Tcl 8.4 +package require Tcl 8.5 9 namespace eval ::struct { # Supporting code for the main command. @@ -58,7 +56,7 @@ namespace eval ::struct { int m; if (objc < 2) { - Tcl_WrongNumArgs (interp, objc, objv, "cmd ?arg ...?"); + Tcl_WrongNumArgs (interp, objc, objv, "cmd ?arg ...?"); /* OK tcl9 */ return TCL_ERROR; } else if (Tcl_GetIndexFromObj (interp, objv [1], methods, "option", 0, &m) != TCL_OK) { diff --git a/src/bootsupport/lib/struct/sets_tcl.tcl b/src/bootsupport/lib/struct/sets_tcl.tcl index a2e1fde3..2dcc5902 100644 --- a/src/bootsupport/lib/struct/sets_tcl.tcl +++ b/src/bootsupport/lib/struct/sets_tcl.tcl @@ -13,7 +13,7 @@ # #---------------------------------------------------------------------- -package require Tcl 8.0 +package require Tcl 8.5 9 namespace eval ::struct::set { # Only export one command, the one used to instantiate a new tree diff --git a/src/bootsupport/lib/struct/skiplist.tcl b/src/bootsupport/lib/struct/skiplist.tcl index 579f0ef3..169ba5c3 100644 --- a/src/bootsupport/lib/struct/skiplist.tcl +++ b/src/bootsupport/lib/struct/skiplist.tcl @@ -434,4 +434,4 @@ namespace eval ::struct { namespace import -force skiplist::skiplist namespace export skiplist } -package provide struct::skiplist 1.3 +package provide struct::skiplist 1.4 diff --git a/src/bootsupport/lib/struct/stack.tcl b/src/bootsupport/lib/struct/stack.tcl index 0dcbca2b..da8d66f9 100644 --- a/src/bootsupport/lib/struct/stack.tcl +++ b/src/bootsupport/lib/struct/stack.tcl @@ -12,7 +12,7 @@ # @mdgen EXCLUDE: stack_c.tcl -package require Tcl 8.4 +package require Tcl 8.5 9 namespace eval ::struct::stack {} # ### ### ### ######### ######### ######### @@ -35,16 +35,12 @@ proc ::struct::stack::LoadAccelerator {key} { switch -exact -- $key { critcl { # Critcl implementation of stack requires Tcl 8.4. - if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} if {[catch {package require tcllibc}]} {return 0} set r [llength [info commands ::struct::stack_critcl]] } tcl { variable selfdir - if { - [package vsatisfies [package provide Tcl] 8.5] && - ![catch {package require TclOO 0.6.1-} mx] - } { + if {![catch {package require TclOO 0.6.1-} mx]} { source [file join $selfdir stack_oo.tcl] } else { source [file join $selfdir stack_tcl.tcl] @@ -184,4 +180,4 @@ namespace eval ::struct { namespace export stack } -package provide struct::stack 1.5.3 +package provide struct::stack 1.5.4 diff --git a/src/bootsupport/lib/struct/stack_c.tcl b/src/bootsupport/lib/struct/stack_c.tcl index 8345d80c..f3fde2e4 100644 --- a/src/bootsupport/lib/struct/stack_c.tcl +++ b/src/bootsupport/lib/struct/stack_c.tcl @@ -14,7 +14,7 @@ package require critcl # @sak notprovided struct_stackc package provide struct_stackc 1.3.1 -package require Tcl 8.4 +package require Tcl 8.5 9 namespace eval ::struct { # Supporting code for the main command. @@ -98,7 +98,7 @@ namespace eval ::struct { #define USAGE "?name?" if ((objc != 2) && (objc != 1)) { - Tcl_WrongNumArgs (interp, 1, objv, USAGE); + Tcl_WrongNumArgs (interp, 1, objv, USAGE); /* OK tcl9 */ return TCL_ERROR; } @@ -117,11 +117,11 @@ namespace eval ::struct { Tcl_IncrRefCount (fqn); if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) { - Tcl_AppendToObj (fqn, "::", -1); + Tcl_AppendToObj (fqn, "::", -1); /* OK tcl9 */ } - Tcl_AppendToObj (fqn, name, -1); + Tcl_AppendToObj (fqn, name, -1); /* OK tcl9 */ } else { - fqn = Tcl_NewStringObj (name, -1); + fqn = Tcl_NewStringObj (name, -1); /* OK tcl9 */ Tcl_IncrRefCount (fqn); } Tcl_ResetResult (interp); @@ -132,9 +132,9 @@ namespace eval ::struct { Tcl_Obj* err; err = Tcl_NewObj (); - Tcl_AppendToObj (err, "command \"", -1); + Tcl_AppendToObj (err, "command \"", -1); /* OK tcl9 */ Tcl_AppendObjToObj (err, fqn); - Tcl_AppendToObj (err, "\" already exists, unable to create stack", -1); + Tcl_AppendToObj (err, "\" already exists, unable to create stack", -1); /* OK tcl9 */ Tcl_DecrRefCount (fqn); Tcl_SetObjResult (interp, err); @@ -142,9 +142,9 @@ namespace eval ::struct { } sd = st_new(); - sd->cmd = Tcl_CreateObjCommand (interp, Tcl_GetString (fqn), - stms_objcmd, (ClientData) sd, - SDdeleteCmd); + sd->cmd = Tcl_CreateObjCommand2 (interp, Tcl_GetString (fqn), + stms_objcmd, (ClientData) sd, + SDdeleteCmd); Tcl_SetObjResult (interp, fqn); Tcl_DecrRefCount (fqn); diff --git a/src/bootsupport/lib/struct/stack_oo.tcl b/src/bootsupport/lib/struct/stack_oo.tcl index f7520c15..ff049258 100644 --- a/src/bootsupport/lib/struct/stack_oo.tcl +++ b/src/bootsupport/lib/struct/stack_oo.tcl @@ -9,7 +9,7 @@ # # RCS: @(#) $Id: stack_oo.tcl,v 1.4 2010/09/10 17:31:04 andreas_kupries Exp $ -package require Tcl 8.5 +package require Tcl 8.5 9 package require TclOO 0.6.1- ; # This includes 1 and higher. # Cleanup first diff --git a/src/bootsupport/lib/struct/stack_tcl.tcl b/src/bootsupport/lib/struct/stack_tcl.tcl index a11f6355..1bcc6047 100644 --- a/src/bootsupport/lib/struct/stack_tcl.tcl +++ b/src/bootsupport/lib/struct/stack_tcl.tcl @@ -86,7 +86,7 @@ proc ::struct::stack::stack_tcl {args} { # Results: # Varies based on command to perform -if {[package vsatisfies [package provide Tcl] 8.5]} { +if {[package vsatisfies [package provide Tcl] 8.5 9]} { # In 8.5+ we can do an ensemble for fast dispatch. proc ::struct::stack::StackProc {name cmd args} { @@ -393,7 +393,7 @@ proc ::struct::stack::I::pop {name {count 1}} { # Results: # None. -if {[package vsatisfies [package provide Tcl] 8.5]} { +if {[package vsatisfies [package provide Tcl] 8.5 9]} { proc ::struct::stack::I::push {name args} { if {![llength $args]} { diff --git a/src/bootsupport/lib/struct/struct.tcl b/src/bootsupport/lib/struct/struct.tcl index c909472b..117b6696 100644 --- a/src/bootsupport/lib/struct/struct.tcl +++ b/src/bootsupport/lib/struct/struct.tcl @@ -1,4 +1,4 @@ -package require Tcl 8.2 +package require Tcl 8.5 9 package require struct::graph 2.0 package require struct::queue 1.2.1 package require struct::stack 1.2.1 @@ -9,10 +9,10 @@ package require struct::record 1.2.1 package require struct::list 1.4 package require struct::set 2.1 package require struct::prioqueue 1.3 -package require struct::skiplist 1.3 +package require struct::skiplist 1.4 namespace eval ::struct { namespace export * } -package provide struct 2.1 +package provide struct 2.2 diff --git a/src/bootsupport/lib/struct/struct1.tcl b/src/bootsupport/lib/struct/struct1.tcl index 7ff3e392..af3f6d9d 100644 --- a/src/bootsupport/lib/struct/struct1.tcl +++ b/src/bootsupport/lib/struct/struct1.tcl @@ -1,5 +1,5 @@ -package require Tcl 8.2 -package require struct::graph 1.2.1 +package require Tcl 8.5 9 +package require struct::graph 1.2.2 package require struct::queue 1.2.1 package require struct::stack 1.2.1 package require struct::tree 1.2.1 @@ -8,10 +8,10 @@ package require struct::pool 1.2.1 package require struct::record 1.2.1 package require struct::list 1.4 package require struct::prioqueue 1.3 -package require struct::skiplist 1.3 +package require struct::skiplist 1.4 namespace eval ::struct { namespace export * } -package provide struct 1.4 +package provide struct 1.5 diff --git a/src/bootsupport/lib/struct/tree.tcl b/src/bootsupport/lib/struct/tree.tcl index d3430f44..52b9fe71 100644 --- a/src/bootsupport/lib/struct/tree.tcl +++ b/src/bootsupport/lib/struct/tree.tcl @@ -11,7 +11,7 @@ # @mdgen EXCLUDE: tree_c.tcl -package require Tcl 8.2 +package require Tcl 8.5 9 package require struct::list namespace eval ::struct::tree {} @@ -36,7 +36,6 @@ proc ::struct::tree::LoadAccelerator {key} { switch -exact -- $key { critcl { # Critcl implementation of tree requires Tcl 8.4. - if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} if {[catch {package require tcllibc}]} {return 0} set r [llength [info commands ::struct::tree_critcl]] } @@ -180,4 +179,4 @@ namespace eval ::struct { namespace export tree } -package provide struct::tree 2.1.2 +package provide struct::tree 2.1.3 diff --git a/src/bootsupport/lib/struct/tree1.tcl b/src/bootsupport/lib/struct/tree1.tcl index 726396e9..9de0e0b9 100644 --- a/src/bootsupport/lib/struct/tree1.tcl +++ b/src/bootsupport/lib/struct/tree1.tcl @@ -9,7 +9,7 @@ # # RCS: @(#) $Id: tree1.tcl,v 1.5 2005/10/04 17:15:05 andreas_kupries Exp $ -package require Tcl 8.2 +package require Tcl 8.5 9 namespace eval ::struct {} @@ -1482,4 +1482,4 @@ namespace eval ::struct { namespace import -force tree::tree namespace export tree } -package provide struct::tree 1.2.2 +package provide struct::tree 1.2.3 diff --git a/src/bootsupport/lib/struct/tree_c.tcl b/src/bootsupport/lib/struct/tree_c.tcl index d8f112a8..bb511900 100644 --- a/src/bootsupport/lib/struct/tree_c.tcl +++ b/src/bootsupport/lib/struct/tree_c.tcl @@ -8,13 +8,11 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: tree_c.tcl,v 1.6 2008/03/25 07:15:34 andreas_kupries Exp $ package require critcl # @sak notprovided struct_treec package provide struct_treec 2.1.1 -package require Tcl 8.2 +package require Tcl 8.5 9 namespace eval ::struct { # Supporting code for the main command. @@ -100,7 +98,7 @@ namespace eval ::struct { #define USAGE "?name ?=|:=|as|deserialize source??" if ((objc != 4) && (objc != 2) && (objc != 1)) { - Tcl_WrongNumArgs (interp, 1, objv, USAGE); + Tcl_WrongNumArgs (interp, 1, objv, USAGE); /* OK tcl9 */ return TCL_ERROR; } @@ -119,11 +117,11 @@ namespace eval ::struct { Tcl_IncrRefCount (fqn); if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) { - Tcl_AppendToObj (fqn, "::", -1); + Tcl_AppendToObj (fqn, "::", -1); /* OK tcl9 */ } - Tcl_AppendToObj (fqn, name, -1); + Tcl_AppendToObj (fqn, name, -1); /* OK tcl9 */ } else { - fqn = Tcl_NewStringObj (name, -1); + fqn = Tcl_NewStringObj (name, -1); /* OK tcl9 */ Tcl_IncrRefCount (fqn); } Tcl_ResetResult (interp); @@ -134,9 +132,9 @@ namespace eval ::struct { Tcl_Obj* err; err = Tcl_NewObj (); - Tcl_AppendToObj (err, "command \"", -1); + Tcl_AppendToObj (err, "command \"", -1); /* OK tcl9 */ Tcl_AppendObjToObj (err, fqn); - Tcl_AppendToObj (err, "\" already exists, unable to create tree", -1); + Tcl_AppendToObj (err, "\" already exists, unable to create tree", -1); /* OK tcl9 */ Tcl_DecrRefCount (fqn); Tcl_SetObjResult (interp, err); @@ -159,7 +157,7 @@ namespace eval ::struct { 0, &srctype) != TCL_OK) { Tcl_DecrRefCount (fqn); Tcl_ResetResult (interp); - Tcl_WrongNumArgs (interp, 1, objv, USAGE); + Tcl_WrongNumArgs (interp, 1, objv, USAGE); /* OK tcl9 */ return TCL_ERROR; } @@ -188,9 +186,9 @@ namespace eval ::struct { td = t_new (); } - td->cmd = Tcl_CreateObjCommand (interp, Tcl_GetString (fqn), - tms_objcmd, (ClientData) td, - TDdeleteCmd); + td->cmd = Tcl_CreateObjCommand2 (interp, Tcl_GetString (fqn), + tms_objcmd, (ClientData) td, + TDdeleteCmd); Tcl_SetObjResult (interp, fqn); Tcl_DecrRefCount (fqn); diff --git a/src/bootsupport/lib/struct/tree_tcl.tcl b/src/bootsupport/lib/struct/tree_tcl.tcl index fbbc3575..303c2d0e 100644 --- a/src/bootsupport/lib/struct/tree_tcl.tcl +++ b/src/bootsupport/lib/struct/tree_tcl.tcl @@ -9,7 +9,7 @@ # # RCS: @(#) $Id: tree_tcl.tcl,v 1.5 2009/06/22 18:21:59 andreas_kupries Exp $ -package require Tcl 8.2 +package require Tcl 8.5 9 package require struct::list namespace eval ::struct::tree { diff --git a/src/bootsupport/lib/term/ansi/code.tcl b/src/bootsupport/lib/term/ansi/code.tcl index a8f7d3e9..95792252 100644 --- a/src/bootsupport/lib/term/ansi/code.tcl +++ b/src/bootsupport/lib/term/ansi/code.tcl @@ -50,7 +50,7 @@ namespace eval ::term::ansi::code { # ### ### ### ######### ######### ######### ## Ready -package provide term::ansi::code 0.2 +package provide term::ansi::code 0.3 ## # ### ### ### ######### ######### ######### diff --git a/src/bootsupport/lib/term/ansi/code/attr.tcl b/src/bootsupport/lib/term/ansi/code/attr.tcl index d7d062b8..20e622e7 100644 --- a/src/bootsupport/lib/term/ansi/code/attr.tcl +++ b/src/bootsupport/lib/term/ansi/code/attr.tcl @@ -102,7 +102,7 @@ namespace eval ::term::ansi::code::attr { # ### ### ### ######### ######### ######### ## Ready -package provide term::ansi::code::attr 0.1 +package provide term::ansi::code::attr 0.2 ## # ### ### ### ######### ######### ######### diff --git a/src/bootsupport/lib/term/ansi/code/ctrl.tcl b/src/bootsupport/lib/term/ansi/code/ctrl.tcl index eb2e3b24..f0f8ca56 100644 --- a/src/bootsupport/lib/term/ansi/code/ctrl.tcl +++ b/src/bootsupport/lib/term/ansi/code/ctrl.tcl @@ -266,7 +266,7 @@ namespace eval ::term::ansi::code::ctrl { # ### ### ### ######### ######### ######### ## Ready -package provide term::ansi::code::ctrl 0.3 +package provide term::ansi::code::ctrl 0.4 ## # ### ### ### ######### ######### ######### diff --git a/src/bootsupport/lib/term/ansi/code/macros.tcl b/src/bootsupport/lib/term/ansi/code/macros.tcl index 1f1d47d3..efcbd31e 100644 --- a/src/bootsupport/lib/term/ansi/code/macros.tcl +++ b/src/bootsupport/lib/term/ansi/code/macros.tcl @@ -87,7 +87,7 @@ namespace eval ::term::ansi::code::macros { # ### ### ### ######### ######### ######### ## Ready -package provide term::ansi::code::macros 0.1 +package provide term::ansi::code::macros 0.2 ## # ### ### ### ######### ######### ######### diff --git a/src/bootsupport/lib/term/ansi/ctrlunix.tcl b/src/bootsupport/lib/term/ansi/ctrlunix.tcl index 675348c7..263ec9d4 100644 --- a/src/bootsupport/lib/term/ansi/ctrlunix.tcl +++ b/src/bootsupport/lib/term/ansi/ctrlunix.tcl @@ -85,7 +85,7 @@ namespace eval ::term::ansi::ctrl::unix { # ### ### ### ######### ######### ######### ## Ready -package provide term::ansi::ctrl::unix 0.1.1 +package provide term::ansi::ctrl::unix 0.1.2 ## # ### ### ### ######### ######### ######### diff --git a/src/bootsupport/lib/term/ansi/send.tcl b/src/bootsupport/lib/term/ansi/send.tcl index d47f834a..895a30c2 100644 --- a/src/bootsupport/lib/term/ansi/send.tcl +++ b/src/bootsupport/lib/term/ansi/send.tcl @@ -5,7 +5,7 @@ # ### ### ### ######### ######### ######### ## Requirements -package require Tcl 8.4 +package require Tcl 8.5 9 package require term::send package require term::ansi::code::ctrl @@ -86,7 +86,7 @@ namespace eval ::term::ansi::send { # ### ### ### ######### ######### ######### ## Ready -package provide term::ansi::send 0.2 +package provide term::ansi::send 0.3 ## # ### ### ### ######### ######### ######### diff --git a/src/bootsupport/lib/term/bind.tcl b/src/bootsupport/lib/term/bind.tcl index 8342442d..cd0b8600 100644 --- a/src/bootsupport/lib/term/bind.tcl +++ b/src/bootsupport/lib/term/bind.tcl @@ -126,7 +126,7 @@ snit::type ::term::receive::bind { # ### ### ### ######### ######### ######### ## Ready -package provide term::receive::bind 0.1 +package provide term::receive::bind 0.2 ## # ### ### ### ######### ######### ######### diff --git a/src/bootsupport/lib/term/imenu.tcl b/src/bootsupport/lib/term/imenu.tcl index 42a7fab5..c752027b 100644 --- a/src/bootsupport/lib/term/imenu.tcl +++ b/src/bootsupport/lib/term/imenu.tcl @@ -196,7 +196,7 @@ namespace eval ::term::interact::menu { term::ansi::send::import vt } -package provide term::interact::menu 0.1 +package provide term::interact::menu 0.2 ## # ### ### ### ######### ######### ######### diff --git a/src/bootsupport/lib/term/ipager.tcl b/src/bootsupport/lib/term/ipager.tcl index 59c1c580..47e5704a 100644 --- a/src/bootsupport/lib/term/ipager.tcl +++ b/src/bootsupport/lib/term/ipager.tcl @@ -200,7 +200,7 @@ namespace eval ::term::interact::pager { term::ansi::send::import vt } -package provide term::interact::pager 0.1 +package provide term::interact::pager 0.2 ## # ### ### ### ######### ######### ######### diff --git a/src/bootsupport/lib/term/pkgIndex.tcl b/src/bootsupport/lib/term/pkgIndex.tcl index bd06c3a8..2493ae7d 100644 --- a/src/bootsupport/lib/term/pkgIndex.tcl +++ b/src/bootsupport/lib/term/pkgIndex.tcl @@ -1,13 +1,13 @@ -if {![package vsatisfies [package provide Tcl] 8.4]} return -package ifneeded term 0.1 [list source [file join $dir term.tcl]] -package ifneeded term::ansi::code 0.2 [list source [file join $dir ansi/code.tcl]] -package ifneeded term::ansi::code::attr 0.1 [list source [file join $dir ansi/code/attr.tcl]] -package ifneeded term::ansi::code::ctrl 0.3 [list source [file join $dir ansi/code/ctrl.tcl]] -package ifneeded term::ansi::code::macros 0.1 [list source [file join $dir ansi/code/macros.tcl]] -package ifneeded term::ansi::ctrl::unix 0.1.1 [list source [file join $dir ansi/ctrlunix.tcl]] -package ifneeded term::ansi::send 0.2 [list source [file join $dir ansi/send.tcl]] -package ifneeded term::interact::menu 0.1 [list source [file join $dir imenu.tcl]] -package ifneeded term::interact::pager 0.1 [list source [file join $dir ipager.tcl]] -package ifneeded term::receive 0.1 [list source [file join $dir receive.tcl]] -package ifneeded term::receive::bind 0.1 [list source [file join $dir bind.tcl]] -package ifneeded term::send 0.1 [list source [file join $dir send.tcl]] +if {![package vsatisfies [package provide Tcl] 8.5 9]} return +package ifneeded term 0.2 [list source [file join $dir term.tcl]] +package ifneeded term::ansi::code 0.3 [list source [file join $dir ansi/code.tcl]] +package ifneeded term::ansi::code::attr 0.2 [list source [file join $dir ansi/code/attr.tcl]] +package ifneeded term::ansi::code::ctrl 0.4 [list source [file join $dir ansi/code/ctrl.tcl]] +package ifneeded term::ansi::code::macros 0.2 [list source [file join $dir ansi/code/macros.tcl]] +package ifneeded term::ansi::ctrl::unix 0.1.2 [list source [file join $dir ansi/ctrlunix.tcl]] +package ifneeded term::ansi::send 0.3 [list source [file join $dir ansi/send.tcl]] +package ifneeded term::interact::menu 0.2 [list source [file join $dir imenu.tcl]] +package ifneeded term::interact::pager 0.2 [list source [file join $dir ipager.tcl]] +package ifneeded term::receive 0.2 [list source [file join $dir receive.tcl]] +package ifneeded term::receive::bind 0.2 [list source [file join $dir bind.tcl]] +package ifneeded term::send 0.2 [list source [file join $dir send.tcl]] diff --git a/src/bootsupport/lib/term/receive.tcl b/src/bootsupport/lib/term/receive.tcl index 393549c2..dfc56d6e 100644 --- a/src/bootsupport/lib/term/receive.tcl +++ b/src/bootsupport/lib/term/receive.tcl @@ -54,7 +54,7 @@ namespace eval ::term::receive { # ### ### ### ######### ######### ######### ## Ready -package provide term::receive 0.1 +package provide term::receive 0.2 ## # ### ### ### ######### ######### ######### diff --git a/src/bootsupport/lib/term/send.tcl b/src/bootsupport/lib/term/send.tcl index c3e235de..4feaa119 100644 --- a/src/bootsupport/lib/term/send.tcl +++ b/src/bootsupport/lib/term/send.tcl @@ -28,7 +28,7 @@ namespace eval ::term::send { # ### ### ### ######### ######### ######### ## Ready -package provide term::send 0.1 +package provide term::send 0.2 ## # ### ### ### ######### ######### ######### diff --git a/src/bootsupport/lib/term/term.tcl b/src/bootsupport/lib/term/term.tcl index 01d4630c..ec188d52 100644 --- a/src/bootsupport/lib/term/term.tcl +++ b/src/bootsupport/lib/term/term.tcl @@ -13,7 +13,7 @@ namespace eval ::term {} # ### ### ### ######### ######### ######### ## Ready -package provide term 0.1 +package provide term 0.2 ## # ### ### ### ######### ######### ######### diff --git a/src/bootsupport/modules/fauxlink-0.1.0.tm b/src/bootsupport/modules/fauxlink-0.1.0.tm index 8424ce07..d0fdc8ec 100644 --- a/src/bootsupport/modules/fauxlink-0.1.0.tm +++ b/src/bootsupport/modules/fauxlink-0.1.0.tm @@ -66,6 +66,16 @@ # "my-program-files#++server+c+Program%20Files.fxlnk" #If we needed the old-style literal %20 it would become # "my-program-files#++server+c+Program%2520Files.fxlnk" +# +# The file:// scheme on windows supposedly *does* decode %xx (for use in a browser) +# e.g +# pfiles#file%3a++++localhost+c+Program%2520files +# The browser will work with literal spaces too though - so it could just as well be: +# pfiles#file%3a++++localhost+c+Program%20files +#windows may default to using explorer.exe instead of a browser for file:// urls though +#and explorer doesn't want the literal %20. It probably depends what API the file:// url is to be passed to? +#in a .url shortcut either literal space or %20 will work ie %xx values are decoded + #*** !doctools diff --git a/src/bootsupport/modules/include_modules.config b/src/bootsupport/modules/include_modules.config index 922ff786..17b5192a 100644 --- a/src/bootsupport/modules/include_modules.config +++ b/src/bootsupport/modules/include_modules.config @@ -14,7 +14,6 @@ set bootsupport_modules [list\ src/vendormodules debug\ src/vendormodules dictutils\ src/vendormodules fauxlink\ - src/vendormodules fileutil\ src/vendormodules http\ src/vendormodules md5\ src/vendormodules metaface\ diff --git a/src/bootsupport/modules/punk-0.1.tm b/src/bootsupport/modules/punk-0.1.tm index 2d6e61da..4bd8aae0 100644 --- a/src/bootsupport/modules/punk-0.1.tm +++ b/src/bootsupport/modules/punk-0.1.tm @@ -213,6 +213,13 @@ namespace eval punk { proc objclone {obj} { append obj2 $obj {} } + proc set_clone {varname obj} { + #maintenance: also punk::lib::set_clone + #e.g used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_clone varnmame $val] + append obj2 $obj {} + uplevel 1 [list set $varname $obj2] + } + interp alias "" strlen "" ::punk::strlen interp alias "" str_len "" ::punk::strlen interp alias "" objclone "" ::punk::objclone @@ -2121,8 +2128,8 @@ namespace eval punk { set level_script_complete 1 } {@V\*@*} - {@v\*@*} { - #dict value glob - return values - set active_key_type "dict" + #dict value glob - return values + set active_key_type dict set keyglob [string range $index 4 end] append script [tstr -return string -allowcommands { if {[catch {dict size $leveldata}]} { @@ -2132,7 +2139,7 @@ namespace eval punk { if {$get_not} { lappend INDEX_OPERATIONS globvalue-get-values-not append script \n [string map [list $keyglob] { - # set active_key_type "dict" index_operation: globvalue-get-values-not" + # set active_key_type "dict" ;# index_operation: globvalue-get-values-not set assigned [list] tcl::dict::for {k v} $leveldata { if {![string match $v]} { @@ -2144,7 +2151,7 @@ namespace eval punk { } else { lappend INDEX_OPERATIONS globvalue-get-values append script \n [string map [list $keyglob] { - # set active_key_type "dict" index_operation: globvalue-get-value + # set active_key_type "dict" ;#index_operation: globvalue-get-value set assigned [dict values $leveldata ] }] } @@ -2166,7 +2173,7 @@ namespace eval punk { } else { lappend INDEX_OPERATIONS globkeyvalue-get-pairs append script \n [string map [list $keyvalglob] { - # set active_key_type "dict" index_operation: globkeyvalue-get-pairs-not" + # set active_key_type "dict" ;# index_operation: globkeyvalue-get-pairs-not set assigned [dict create] tcl::dict::for {k v} $leveldata { if {[string match $k] || [string match $v]} { @@ -4952,17 +4959,14 @@ namespace eval punk { } else { #tags ? #debug.punk.pipe {>>raw commandline: [concat $rhs $segment_members_filled]} 5 - if 0 { - - - + if {false} { #set s [list uplevel 1 [concat $rhs $segment_members_filled]] if {![info exists pscript]} { upvar ::_pipescript pscript } if {![info exists pscript]} { #set pscript $s - set pscript [funcl::o_of_n 1 $segment_members] + set pscript [funcl::o_of_n 1 $segment_members] } else { #set pscript [string map [list

$pscript] {uplevel 1 [concat $rhs $segment_members_filled [

]]}] #set snew "set pipe_$i \[uplevel 1 \[list $rhs $segment_members_filled " @@ -4972,6 +4976,7 @@ namespace eval punk { } } + set cmdlist_result [uplevel 1 $segment_members_filled] #set d [_multi_bind_result $returnvarspec [punk::K $segment_members_filled [unset segment_members_filled]]] set d [_multi_bind_result $returnvarspec [lindex [list $cmdlist_result [unset cmdlist_result]] 0 ]] @@ -7321,16 +7326,22 @@ namespace eval punk { if {$topic in [list tcl]} { - if {[punk::lib::system::has_script_var_bug]} { - append warningblock \n "minor warning: punk::lib::system::has_script_var_bug returned true! (string rep for list variable in script generated when script changed)" + if {[punk::lib::system::has_tclbug_script_var]} { + append warningblock \n "minor warning: punk::lib::system::has_tclbug_script_var returned true! (string rep for list variable in script generated when script changed)" } - if {[punk::lib::system::has_safeinterp_compile_bug]} { + if {[punk::lib::system::has_tclbug_safeinterp_compile]} { set indent " " - append warningblock \n "[a+ web-red]warning: punk::lib::system::has_safeinterp_compile_bug returned true!" \n + append warningblock \n "[a+ web-red]warning: punk::lib::system::has_tclbug_safeinterp returned true!" \n append warningblock "${indent}(ensemble commands not compiled in safe interps - heavy performance impact in safe interps)" \n append warningblock "${indent}see https://core.tcl-lang.org/tcl/tktview/1095bf7f75" append warningblock [a] } + if {[punk::lib::system::has_tclbug_list_quoting_emptyjoin]} { + set indent " " + append warningblock \n "[a+ web-red]warning: punk::lib::system::has_tclbug_list_quoting returned true!" \n + append warningblock "${indent}lists elements not properly quoted in some cases. e.g 'list {*}[lindex {etc #foo} 1] {*}[list]' (#foo not braced)" \n + append warningblock "${indent}see https://core.tcl-lang.org/tcl/tktview/e38dce74e2" + } } set text "" diff --git a/src/bootsupport/modules/punk/args-0.1.0.tm b/src/bootsupport/modules/punk/args-0.1.0.tm index 5e270ac8..c8a6ec84 100644 --- a/src/bootsupport/modules/punk/args-0.1.0.tm +++ b/src/bootsupport/modules/punk/args-0.1.0.tm @@ -201,6 +201,7 @@ #[para] packages used by punk::args #[list_begin itemized] package require Tcl 8.6- +#optional? punk::trie #*** !doctools #[item] [package {Tcl 8.6-}] @@ -293,6 +294,7 @@ tcl::namespace::eval punk::args { -validate_without_ansi 0\ -strip_ansi 0\ -nocase 0\ + -choiceprefix 1\ -multiple 0\ ] set valspec_defaults [tcl::dict::create\ @@ -301,8 +303,12 @@ tcl::namespace::eval punk::args { -allow_ansi 1\ -validate_without_ansi 0\ -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ -multiple 0\ ] + #we need a -choiceprefix default even though it often doesn't apply so we can look it up to display in Help if there are -choices + #default to 1 for convenience #checks with no default #-minlen -maxlen -range @@ -415,11 +421,11 @@ tcl::namespace::eval punk::args { -anyopts { set opt_any $v } - -minlen - -maxlen - -range - -choices - -choicelabels { + -minlen - -maxlen - -range - -choices - -choicelabels - -choiceprefix { #review - only apply to certain types? tcl::dict::set optspec_defaults $k $v } - -nominlen - -nomaxlen - -norange - -nochoices - -nochoicelabels { + -nominlen - -nomaxlen - -norange - -nochoices - -nochoicelabels - -nocase { if {$v} { tcl::dict::unset optspec_defaults $k } @@ -459,7 +465,7 @@ tcl::namespace::eval punk::args { tcl::dict::set optspec_defaults $k $v } default { - set known { -any -anyopts -minlen -maxlen -range -choices -choicelabels\ + set known { -any -anyopts -minlen -maxlen -range -choices -choicelabels -choiceprefix -nocase\ -nominlen -nomaxlen -norange -nochoices -nochoicelabels\ -type -optional -allow_ansi -validate_without_ansi -strip_ansi -multiple\ } @@ -479,7 +485,7 @@ tcl::namespace::eval punk::args { -maxvalues { set val_max $v } - -minlen - -maxlen - -range - -choices - -choicelabels { + -minlen - -maxlen - -range - -choices - -choicelabels - -choiceprefix - -nocase { #review - only apply to certain types? tcl::dict::set valspec_defaults $k $v } @@ -520,7 +526,7 @@ tcl::namespace::eval punk::args { } default { set known { -min -minvalues -max -maxvalues\ - -minlen -maxlen -range -choices -choicelabels\ + -minlen -maxlen -range -choices -choicelabels -choiceprefix -nocase\ -nominlen -nomaxlen -norange -nochoices -nochoicelabels\ -type -optional -allow_ansi -validate_without_ansi -strip_ansi -multiple\ } @@ -596,12 +602,12 @@ tcl::namespace::eval punk::args { } } } - -default - -solo - -range - -choices - -choicelabels - -minlen - -maxlen - -nocase - -optional - -multiple - -validate_without_ansi - -allow_ansi - -strip_ansi - -help - -ARGTYPE { + -default - -solo - -range - -choices - -choiceprefix - -choicelabels - -choiceprefix - -minlen - -maxlen - -nocase - -optional - -multiple - -validate_without_ansi - -allow_ansi - -strip_ansi - -help - -ARGTYPE { #review -solo 1 vs -type none ? tcl::dict::set spec_merged $spec $specval } default { - set known_argspecs [list -default -type -range -choices -nocase -optional -multiple -validate_without_ansi -allow_ansi -strip_ansi -help] + set known_argspecs [list -default -type -range -choices -choiceprefix -nocase -optional -multiple -validate_without_ansi -allow_ansi -strip_ansi -help] error "punk::args::get_dict - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argspecs" } } @@ -752,7 +758,28 @@ tcl::namespace::eval punk::args { #set greencheck [a+ web-limegreen]\u2713[a] set greencheck [a+ brightgreen]\u2713[a] - foreach arg [dict get $spec_dict opt_names] { + if {![catch {package require punk::trie}]} { + set opt_names_display [list] + set trie [punk::trie::trieclass new {*}[dict get $spec_dict opt_names]] + set idents [dict get [$trie shortest_idents ""] scanned] + $trie destroy + set M "\x1b\[32m" ;#mark in green + set RST "\x1b\[m" + foreach c [dict get $spec_dict opt_names] { + set id [dict get $idents $c] + if {$id eq $c} { + lappend opt_names_display $M$c$RST + } else { + set idlen [string length $id] + lappend opt_names_display "$M[string range $c 0 $idlen-1]$RST[string range $c $idlen end]" + } + } + } else { + set opt_names_display [dict get $spec_dict opt_names] + } + + + foreach argshow $opt_names_display arg [dict get $spec_dict opt_names] { set arginfo [dict get $spec_dict arg_info $arg] if {[dict exists $arginfo -default]} { #set default $c_default[dict get $arginfo -default] @@ -763,14 +790,47 @@ tcl::namespace::eval punk::args { set help [punk::lib::dict_getdef $arginfo -help ""] if {[dict exists $arginfo -choices]} { if {$help ne ""} {append help \n} - append help "Choices: [dict get $arginfo -choices]" + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + } else { + set casemsg " (case sensitive)" + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + append help "Choices$prefixmsg$casemsg" + if {[catch {package require punk::trie}]} { + append help "\n " [join [dict get $arginfo -choices] "\n "] + } else { + if {[catch { + set trie [punk::trie::trieclass new {*}[dict get $arginfo -choices]] + set idents [dict get [$trie shortest_idents ""] scanned] + $trie destroy + set M "\x1b\[32m" ;#mark in green + set RST "\x1b\[m" + foreach c [dict get $arginfo -choices] { + set id [dict get $idents $c] + if {$id eq $c} { + append help "\n " "$M$c$RST" + } else { + set idlen [string length $id] + append help "\n " "$M[string range $c 0 $idlen-1]$RST[string range $c $idlen end]" + } + } + } errM]} { + puts stderr "prefix marking failed\n$errM" + append help "\n " [join [dict get $arginfo -choices] "\n "] + } + } } if {[punk::lib::dict_getdef $arginfo -multiple 0]} { set multiple $greencheck } else { set multiple "" } - $t add_row [list $arg [dict get $arginfo -type] $default $multiple $help] + $t add_row [list $argshow [dict get $arginfo -type] $default $multiple $help] if {$arg eq $badarg} { $t configure_row [expr {[$t row_count]-1}] -ansibase $c_badarg } @@ -785,7 +845,40 @@ tcl::namespace::eval punk::args { set help [punk::lib::dict_getdef $arginfo -help ""] if {[dict exists $arginfo -choices]} { if {$help ne ""} {append help \n} - append help "Choices: [dict get $arginfo -choices]" + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + } else { + set casemsg " (case sensitive)" + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + append help "Choices$prefixmsg$casemsg" + if {[catch {package require punk::trie}]} { + append help "\n " [join [dict get $arginfo -choices] "\n "] + } else { + if {[catch { + set trie [punk::trie::trieclass new {*}[dict get $arginfo -choices]] + set idents [dict get [$trie shortest_idents ""] scanned] + $trie destroy + set M "\x1b\[32m" ;#mark in green + set RST "\x1b\[m" + foreach c [dict get $arginfo -choices] { + set id [dict get $idents $c] + if {$id eq $c} { + append help "\n " "$M$c$RST" + } else { + set idlen [string length $id] + append help "\n " "$M[string range $c 0 $idlen-1]$RST[string range $c $idlen end]" + } + } + } errM]} { + puts stderr "prefix marking failed\n$errM" + append help "\n " [join [dict get $arginfo -choices] "\n "] + } + } } if {[punk::lib::dict_getdef $arginfo -multiple 0]} { set multiple $greencheck @@ -1429,20 +1522,38 @@ tcl::namespace::eval punk::args { } if {$has_choices} { #todo -choicelabels - set choices [tcl::dict::get $thisarg -choices] - set nocase [tcl::dict::get $thisarg -nocase] + set choices [tcl::dict::get $thisarg -choices] + set choiceprefix [tcl::dict::get $thisarg -choiceprefix] + set nocase [tcl::dict::get $thisarg -nocase] foreach e $vlist e_check $vlist_check { if {$nocase} { - set casemsg "(case insensitive)" + set casemsg " (case insensitive)" set choices_test [tcl::string::tolower $choices] set v_test [tcl::string::tolower $e_check] } else { - set casemsg "(case sensitive)" + set casemsg " (case sensitive)" set v_test $e_check set choices_test $choices } - if {$v_test ni $choices_test} { - arg_error "Option $argname for [Get_caller] must be one of the listed values $choices $casemsg. Received: '$e'" $argspecs $argname + set choice_ok 0 + if {$choiceprefix} { + if {![catch {tcl::prefix::match $choices_test $v_test} chosen]} { + set choice_ok 1 + #can we handle empty string as a choice? It should just work - REVIEW/test + set choice [lsearch -inline -nocase $choices $chosen] ;#map possibly lcased choice back to original case in choices list + if {[tcl::dict::get $thisarg -ARGTYPE] eq "option"} { + tcl::dict::set opts $argname $choice + } else { + tcl::dict::set values_dict $argname $choice + } + } + set prefixmsg " (or a unique prefix of a value)" + } else { + set prefixmsg "" + set choice_ok [expr {$v_test in $choices_test}] + } + if {!$choice_ok} { + arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $choices "\n "]\n$casemsg$prefixmsg. Received: '$e'" $argspecs $argname } } } diff --git a/src/bootsupport/modules/punk/config-0.1.tm b/src/bootsupport/modules/punk/config-0.1.tm index 206b560b..1e4de9ec 100644 --- a/src/bootsupport/modules/punk/config-0.1.tm +++ b/src/bootsupport/modules/punk/config-0.1.tm @@ -362,10 +362,11 @@ tcl::namespace::eval punk::config { proc configure {args} { set argd [punk::args::get_dict { - - whichconfig -type string -choices {startup running} + *values -min 1 -max 1 + whichconfig -type string -choices {startup running stop} } $args] + return "unimplemented - $argd" } proc show {whichconfig {globfor *}} { diff --git a/src/bootsupport/modules/punk/console-0.1.1.tm b/src/bootsupport/modules/punk/console-0.1.1.tm index 95ecb27d..001a7653 100644 --- a/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/bootsupport/modules/punk/console-0.1.1.tm @@ -44,6 +44,7 @@ #[list_begin itemized] package require Tcl 8.6- +package require Thread ;#tsv required to sync is_raw package require punk::ansi #*** !doctools #[item] [package {Tcl 8.6-}] @@ -84,7 +85,12 @@ namespace eval punk::console { variable previous_stty_state_stdin "" variable previous_stty_state_stdout "" variable previous_stty_state_stderr "" - variable is_raw 0 + + #variable is_raw 0 + if {![tsv::exists console is_raw]} { + tsv::set console is_raw 0 + } + variable input_chunks_waiting if {![info exists input_chunks_waiting(stdin)]} { set input_chunks_waiting(stdin) [list] @@ -183,7 +189,8 @@ namespace eval punk::console { #NOTE - the is_raw is only being set in current interp - but the channel is shared. #this is problematic with the repl thread being separate. - must be a tsv? REVIEW proc enableRaw {{channel stdin}} { - variable is_raw + #variable is_raw + variable previous_stty_state_$channel set sttycmd [auto_execok stty] if {[set previous_stty_state_$channel] eq ""} { @@ -193,21 +200,21 @@ namespace eval punk::console { } exec {*}$sttycmd raw -echo <@$channel - set is_raw 1 + tsv::set console is_raw 1 return [dict create previous [set previous_stty_state_$channel]] } proc disableRaw {{channel stdin}} { - variable is_raw + #variable is_raw variable previous_stty_state_$channel set sttycmd [auto_execok stty] if {[set previous_stty_state_$channel] ne ""} { exec {*}$sttycmd [set previous_stty_state_$channel] set previous_stty_state_$channel "" - set is_raw 0 + tsv::set console is_raw 0 return restored } exec {*}$sttycmd -raw echo <@$channel - set is_raw 0 + tsv::set console is_raw 0 return done } proc enableVirtualTerminal {{channels {input output}}} { @@ -249,11 +256,11 @@ namespace eval punk::console { } proc mode {{raw_or_line query}} { - variable is_raw + #variable is_raw variable ansi_available set raw_or_line [string tolower $raw_or_line] if {$raw_or_line eq "query"} { - if {$is_raw} { + if {[tsv::get console is_raw]} { return "raw" } else { return "line" @@ -493,7 +500,7 @@ namespace eval punk::console { } proc [namespace parent]::enableRaw {{channel stdin}} { - variable is_raw + #variable is_raw variable previous_stty_state_$channel if {[package provide twapi] ne ""} { @@ -506,7 +513,7 @@ namespace eval punk::console { #set newmode [dict merge $oldmode [dict create -lineinput 0 -echoinput 0]] set newmode [twapi::get_console_input_mode] - set is_raw 1 + tsv::set console is_raw 1 #don't disable handler - it will detect is_raw ### twapi::set_console_control_handler {} return [list stdin [list from $oldmode to $newmode]] @@ -516,7 +523,7 @@ namespace eval punk::console { } exec {*}$sttycmd raw -echo <@$channel - set is_raw 1 + tsv::set console is_raw 1 #review - inconsistent return dict return [dict create stdin [list from [set previous_stty_state_$channel] to "" note "fixme - to state not shown"]] } else { @@ -528,7 +535,7 @@ namespace eval punk::console { #could be we were missing a step in reopening stdin and console configuration? proc [namespace parent]::disableRaw {{channel stdin}} { - variable is_raw + #variable is_raw variable previous_stty_state_$channel if {[package provide twapi] ne ""} { @@ -537,7 +544,7 @@ namespace eval punk::console { # Turn on the echo and line-editing bits twapi::modify_console_input_mode $console_handle -lineinput 1 -echoinput 1 set newmode [twapi::get_console_input_mode] - set is_raw 0 + tsv::set console is_raw 0 return [list stdin [list from $oldmode to $newmode]] } elseif {[set sttycmd [auto_execok stty]] ne ""} { #stty can return info on windows - but doesn't seem to be able to set anything. @@ -550,7 +557,7 @@ namespace eval punk::console { return restored } exec {*}$sttycmd -raw echo <@$channel - set is_raw 0 + tsv::set console is_raw 0 #do we really want to exec stty yet again to show final 'to' state? #probably not. We should work out how to read the stty result flags and set a result.. or just limit from,to to showing echo and lineedit states. return [list stdin [list from "[set previous_stty_state_$channel]" to "" note "fixme - to state not shown"]] @@ -634,7 +641,7 @@ namespace eval punk::console { puts -nonewline $output $query;flush $output #todo - test and save rawstate so we don't disableRaw if console was already raw - if {!$::punk::console::is_raw} { + if {![tsv::get console is_raw]} { set was_raw 0 punk::console::enableRaw } else { @@ -1378,7 +1385,7 @@ namespace eval punk::console { #todo - compare speed with get_cursor_pos - work out why the big difference proc test_cursor_pos {} { - if {!$::punk::console::is_raw} { + if {![tsv::get console is_raw]} { set was_raw 0 enableRaw } else { diff --git a/src/bootsupport/modules/punk/du-0.1.0.tm b/src/bootsupport/modules/punk/du-0.1.0.tm index 1e1986e6..9f74d2d5 100644 --- a/src/bootsupport/modules/punk/du-0.1.0.tm +++ b/src/bootsupport/modules/punk/du-0.1.0.tm @@ -1065,56 +1065,65 @@ namespace eval punk::du { #note - with this design, we can't glob for all except dotfiles - this is for cross-platform consistency and efficiency (Review). #dotfiles aren't considered hidden on all platforms #some sort of antiglob is a possible enhancement and more consistent with the view that leading dot should be treated as any other filename character in this context. - if {$opt_glob eq "*"} { - #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink' - #set parent [lindex $folders $folderidx] - set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} * .*] - #set hdirs {} - set dirs [glob -nocomplain -dir $folderpath -types d * .*] - - set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} * .*] - #set hlinks {} - set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. struct::set difference will remove (?) - #set links [lsort -unique [concat $hlinks $links[unset links]]] - - set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} * .*] - #set hfiles {} - set files [glob -nocomplain -dir $folderpath -types f * .*] - #set files {} - } else { - set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} $opt_glob] - set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] + if {"windows" eq $::tcl_platform(platform)} { + if {$opt_glob eq "*"} { + #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink' + #set parent [lindex $folders $folderidx] + set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} * .*] + set dirs [glob -nocomplain -dir $folderpath -types d * .*] + + set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} * .*] + set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique - set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} $opt_glob] - set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. struct::set difference will remove (?) + set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} * .*] + set files [glob -nocomplain -dir $folderpath -types f * .*] + } else { + set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} $opt_glob] + set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] + + set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} $opt_glob] + set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique + + set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} $opt_glob] + set files [glob -nocomplain -dir $folderpath -types f $opt_glob] + } + } else { + set hdirs {} + set hfiles {} + set hlinks {} + if {$opt_glob eq "*"} { + #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink' + #set parent [lindex $folders $folderidx] + set dirs [glob -nocomplain -dir $folderpath -types d * .*] + set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique + set files [glob -nocomplain -dir $folderpath -types f * .*] + } else { + set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] + set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique + set files [glob -nocomplain -dir $folderpath -types f $opt_glob] + } - set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} $opt_glob] - set files [glob -nocomplain -dir $folderpath -types f $opt_glob] } #note struct::set difference produces unordered result #struct::set difference removes duplicates (but not always.. e.g if using tcl impl and 2nd element empty!) - #relying on struct::set to remove dupes is somewhat risky. It is not well documented - and behaviour of dupes in inputs is underspecified as it appears to be intended for mathematical 'sets' + #relying on struct::set to remove dupes is somewhat risky. + #It is not well documented - and behaviour of dupes in inputs is underspecified as it appears to be intended for mathematical 'sets' ie lists without dupes + #for this reason we must use the wrapper punk::lib::struct_set_diff_unique, which will use the well behaved critcl for speed if avail, but fall back to a deduping tcl version #remove links and . .. from directories, remove links from files #ideally we would like to classify links by whether they point to files vs dirs - but there are enough cross-platform differences that we will have to leave it to the caller to sort out for now. #struct::set will affect order: tcl vs critcl give different ordering! - set files [struct::set difference [concat $hfiles $files[unset files]] $links] - set dirs [struct::set difference [concat $hdirs $dirs[unset dirs]] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] - #set links [lsort -unique [concat $links $hlinks]] + set files [punk::lib::struct_set_diff_unique [list {*}$hfiles {*}$files[unset files]] $links] + set dirs [punk::lib::struct_set_diff_unique [list {*}$hdirs {*}$dirs[unset dirs] ] [list {*}$links [file join $folderpath .] [file join $folderpath ..]]] #---- set mdata_lists [du_get_metadata_lists $sized_types $timed_types $files $dirs $links] - - if {"windows" eq $::tcl_platform(platform)} { - set flaggedhidden [concat $hdirs $hfiles $hlinks] - } else { - #unix dotted files/folders are not 'flagged' as such - it's a convention - so the client can use the same convention to decide if something is hidden - #this allows us to return less data - but more importantly - reserve flaggedhidden for systems where such a flag exists and avoid conflating the different concepts of what is hidden - set flaggedhidden {} - } + set flaggedhidden [list {*}$hdirs {*}$hfiles {*}$hlinks] + #unix dotted files/folders are not 'flagged' as such - it's a convention - so the client can use the same convention to decide if something is hidden + #this allows us to return less data - but more importantly - reserve flaggedhidden for systems where such a flag exists and avoid conflating the different concepts of what is hidden set vfsmounts [get_vfsmounts_in_folder $folderpath] @@ -1223,21 +1232,21 @@ namespace eval punk::du { #if {[punk::mix::base::lib::path_a_above_b $folderpath "//zipfs:/"]} {} - #zipfs files also reported as links by glob - review - should we preserve this in response? + #todo - hidden? not returned in attributes on windows at least. + #zipfs files also reported as links by glob - review - should we preserve this in response? (2024 unable to duplicate) if {$opt_glob eq "*"} { set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs - #set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove - set links [list] + set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files } else { set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] - #set links [glob -nocomplain -dir $folderpath -types l $opt_glob] - set links [list] + set links [glob -nocomplain -dir $folderpath -types l $opt_glob] set files [glob -nocomplain -dir $folderpath -types f $opt_glob] } #remove any links from our dirs and files collections - set dirs [struct::set difference $dirs[unset dirs] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] - set files [struct::set difference $files[unset files] $links] + #see du_dirlisting_generic re struct::set difference issues + set dirs [punk::lib::struct_set_diff_unique $dirs[unset dirs] [list {*}$links [file join $folderpath .] [file join $folderpath ..]]] + set files [punk::lib::struct_set_diff_unique $files[unset files] $links] #nested vfs mount.. REVIEW - does anything need special handling? @@ -1300,34 +1309,63 @@ namespace eval punk::du { } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + #at least some vfs on windows seem to support the -hidden attribute + #we are presuming glob will accept the -types hidden option for all vfs - even if it doesn't really apply REVIEW + #The extra globs aren't nice - but hopefully the vfs is reasonably performant (?) set errors [dict create] - if {$opt_glob eq "*"} { - set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs - #review - how are links handled in vfs? presumably if the vfs is a full implementation they should work at least within the vfs? - set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove - set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files + if {"windows" eq $::tcl_platform(platform)} { + if {$opt_glob eq "*"} { + set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} * .*] + set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs + #review - how are links handled in vfs? presumably if the vfs is a full implementation they should work at least within the vfs? + set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} * .*] + set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove + set hfiles [glob -nocomplain -dir $folderpath -types {hidden l} * .*] + set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files + } else { + set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} $opt_glob] + set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] + set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} $opt_glob] + set links [glob -nocomplain -dir $folderpath -types l $opt_glob] + set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} $opt_glob] + set files [glob -nocomplain -dir $folderpath -types f $opt_glob] + } } else { - set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] - set links [glob -nocomplain -dir $folderpath -types l $opt_glob] - set files [glob -nocomplain -dir $folderpath -types f $opt_glob] + #we leave it to the ui on unix to classify dotfiles as hidden + set hdirs {} + set hfiles {} + set hlinks {} + if {$opt_glob eq "*"} { + set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs + #review - how are links handled in vfs? presumably if the vfs is a full implementation they should work at least within the vfs? + set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove + set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files + } else { + set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] + set links [glob -nocomplain -dir $folderpath -types l $opt_glob] + set files [glob -nocomplain -dir $folderpath -types f $opt_glob] + } } #remove any links from our dirs and files collections - set dirs [struct::set difference $dirs[unset dirs] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] - set files [struct::set difference $files[unset files] $links] + #see du_dirlisting_generic re struct::set difference issues + set dirs [punk::lib::struct_set_diff_unique $dirs[unset dirs] [list {*}$links [file join $folderpath .] [file join $folderpath ..] ]] + set files [punk::lib::struct_set_diff_unique $files[unset files] $links] #nested vfs mount.. REVIEW - does anything need special handling? set vfsmounts [get_vfsmounts_in_folder $folderpath] set mdata_lists [du_get_metadata_lists $sized_types $timed_types $files $dirs $links] + set flaggedhidden [list {*}$hdirs {*}$hfiles {*}$hlinks] set effective_opts $opts dict set effective_opts -with_times $timed_types dict set effective_opts -with_sizes $sized_types - return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes [dict get $mdata_lists fsizes] sizes [dict get $mdata_lists allsizes] times [dict get $mdata_lists alltimes] flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {} opts $effective_opts errors $errors] + return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes [dict get $mdata_lists fsizes] sizes [dict get $mdata_lists allsizes] times [dict get $mdata_lists alltimes] flaggedhidden $flaggedhidden flaggedsystem {} flaggedreadonly {} altname {} opts $effective_opts errors $errors] } #we can halve the number of round trips on unix-like systems, where 'hidden' always corresponds to dotted files + #but we don't classify as such anyway. (leave for UI) proc du_dirlisting_unix {folderpath args} { set defaults [dict create\ -glob *\ @@ -1379,6 +1417,9 @@ namespace eval punk::du { } #this is not consistent with standard way * works for unix folders - but it is consistent with behaviour of this facility on windows + #we don't classify anything as 'flaggedhidden' on unix. + #it is a convention for dotfiles rather than a flag - and we'll leave the distinction for the display library + #This if {$opt_glob eq "*"} { set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove @@ -1389,8 +1430,9 @@ namespace eval punk::du { set files [glob -nocomplain -dir $folderpath -types f $opt_glob] } #remove any links from our dirs and files collections - set dirs [struct::set difference $dirs[unset dirs] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] - set files [struct::set difference $files[unset files] $links] + #see du_dirlisting_generic re struct::set difference issues + set dirs [punk::lib::struct_set_diff_unique $dirs[unset dirs] [list {*}$links [file join $folderpath .] [file join $folderpath ..] ]] + set files [punk::lib::struct_set_diff_unique $files[unset files] $links] set vfsmounts [get_vfsmounts_in_folder $folderpath] set mdata_lists [du_get_metadata_lists $sized_types $timed_types $files $dirs $links] @@ -1406,7 +1448,7 @@ namespace eval punk::du { #return fsizes,allsizes,alltimes metadata in same order as files,dirs,links lists - if specified in sized_types proc du_get_metadata_lists {sized_types timed_types files dirs links} { set meta_dict [dict create] - set meta_types [concat $sized_types $timed_types] + set meta_types [list {*}$sized_types {*}$timed_types] #known tcl stat keys 2023 - review set empty_stat_dict [dict create atime {} ctime {} dev {} gid {} ino {} mode {} mtime {} nlink {} size {} type {} uid {}] #make sure we call file stat only once per item @@ -1419,6 +1461,7 @@ namespace eval punk::du { if {![catch {file stat $path arrstat} errM]} { dict set meta_dict $path [dict create shorttype $ft {*}[array get arrstat]] } else { + puts stderr "du_get_metadata_lists: file stat $path error: $errM" dict lappend errors $path "file stat error: $errM" dict set meta_dict $path [dict create shorttype $ft {*}$empty_stat_dict] } @@ -1437,6 +1480,9 @@ namespace eval punk::du { if {$ft eq "f"} { #subst with na if empty? lappend fsizes [dict get $pathinfo size] + if {[dict get $pathinfo size] eq ""} { + puts stderr "du_get_metadata_lists: fsize $path is empty!" + } } } if {$ft in $timed_types} { @@ -1446,7 +1492,7 @@ namespace eval punk::du { #todo - fix . The list lengths will presumably match but have empty values if failed to stat if {"f" in $sized_types} { if {[llength $fsizes] ne [llength $files]} { - dict lappend errors $folderpath "failed to retrieve all file sizes" + dict lappend errors general "failed to retrieve all file sizes" } } return [dict create fsizes $fsizes allsizes $allsizes alltimes $alltimes] diff --git a/src/bootsupport/modules/punk/fileline-0.1.0.tm b/src/bootsupport/modules/punk/fileline-0.1.0.tm index 7e1ee14c..22178177 100644 --- a/src/bootsupport/modules/punk/fileline-0.1.0.tm +++ b/src/bootsupport/modules/punk/fileline-0.1.0.tm @@ -290,7 +290,6 @@ namespace eval punk::fileline::class { -showconfig 0\ -boundaryheader {Boundary %i% at %b%}\ ] - set known_opts [dict keys $defaults] foreach {k v} $args { switch -- $k { -ansi - -offset - -displaybytes - -truncatedmark - -completemark - -moremark - -continuemark - -linemaxwidth - -linebase - -limit - -boundaries - -showconfig - -boundaryheader { diff --git a/src/bootsupport/modules/punk/lib-0.1.1.tm b/src/bootsupport/modules/punk/lib-0.1.1.tm index 8f51075e..070621bc 100644 --- a/src/bootsupport/modules/punk/lib-0.1.1.tm +++ b/src/bootsupport/modules/punk/lib-0.1.1.tm @@ -339,6 +339,144 @@ namespace eval punk::lib { set has_twapi [expr {![catch {package require twapi}]}] } + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + # Maintenance - This is the primary source for tm_version... functions + # - certain packages script require these but without package dependency + # - 1 punk boot script + # - 2 packagetrace module + # - These should be updated to sync with this + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + proc tm_version_isvalid {versionpart} { + #Needs to be suitable for use with Tcl's 'package vcompare' + if {![catch [list package vcompare $versionpart $versionpart]]} { + return 1 + } else { + return 0 + } + } + proc tm_version_major {version} { + if {![tm_version_isvalid $version]} { + error "Invalid version '$version' is not a proper Tcl module version number" + } + set firstpart [lindex [split $version .] 0] + #check for a/b in first segment + if {[string is integer -strict $firstpart]} { + return $firstpart + } + if {[string first a $firstpart] > 0} { + return [lindex [split $firstpart a] 0] + } + if {[string first b $firstpart] > 0} { + return [lindex [split $firstpart b] 0] + } + error "tm_version_major unable to determine major version from version number '$version'" + } + proc tm_version_canonical {ver} { + #accepts a single valid version only - not a bounded or unbounded spec + if {![tm_version_isvalid $ver]} { + error "tm_version_canonical version '$ver' is not valid for a package version" + } + set parts [split $ver .] + set newparts [list] + foreach o $parts { + set trimmed [string trimleft $o 0] + set firstnonzero [string index $trimmed 0] + switch -exact -- $firstnonzero { + "" { + lappend newparts 0 + } + a - b { + #e.g 000bnnnn -> bnnnnn + set tailtrimmed [string trimleft [string range $trimmed 1 end] 0] + if {$tailtrimmed eq ""} { + set tailtrimmed 0 + } + lappend newparts 0$firstnonzero$tailtrimmed + } + default { + #digit + if {[string is integer -strict $trimmed]} { + #e.g 0100 -> 100 + lappend newparts $trimmed + } else { + #e.g 0100b003 -> 100b003 (still need to process tail) + if {[set apos [string first a $trimmed]] > 0} { + set lhs [string range $trimmed 0 $apos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch + set rhs [string range $trimmed $apos+1 end] ;#assert rhs non-empty and only digits + set rhs [string trimleft $rhs 0] + if {$rhs eq ""} { + set rhs 0 + } + lappend newparts ${lhs}a${rhs} + } elseif {[set bpos [string first b $trimmed]] > 0} { + set lhs [string range $trimmed 0 $bpos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch + set rhs [string range $trimmed $bpos+1 end] ;#assert rhs non-empty and only digits + set rhs [string trimleft $rhs 0] + if {$rhs eq ""} { + set rhs 0 + } + lappend newparts ${lhs}b${rhs} + } else { + #assert - shouldn't get here trimmed val should have been empty, an int or contained an a or b + error "tm_version_canonical error - trimfail - unexpected" + } + } + } + } + } + return [join $newparts .] + } + proc tm_version_required_canonical {versionspec} { + #also trim leading zero from any dottedpart? + #Tcl *allows* leading zeros in any of the dotted parts - but they are not significant. + #e.g 1.01 is equivalent to 1.1 and 01.001 + #also 1b3 == 1b0003 + + if {[string trim $versionspec] eq ""} {return ""} ;#unspecified = any version + set errmsg "tm_version_required_canonical - invalid version specification" + if {[string first - $versionspec] < 0} { + #no dash + #looks like a minbounded version (ie a single version with no dash) convert to min-max form + set from $versionspec + if {![tm_version_isvalid $from]} { + error "$errmsg '$versionpec'" + } + if {![catch {tm_version_major $from} majorv]} { + set from [tm_version_canonical $from] + return "${from}-[expr {$majorv +1}]" + } else { + error "$errmsg '$versionspec'" + } + } else { + # min- or min-max + #validation and canonicalisation (strip leading zeroes from each segment, including either side of a or b) + set parts [split $versionspec -] ;#we expect only 2 parts + lassign $parts from to + if {![tm_version_isvalid $from]} { + error "$errmsg '$versionspec'" + } + set from [tm_version_canonical $from] + if {[llength $parts] == 2} { + if {$to ne ""} { + if {![tm_version_isvalid $to]} { + error "$errmsg '$versionspec'" + } + set to [tm_version_canonical $to] + return $from-$to + } else { + return $from- + } + } else { + error "$errmsg '$versionspec'" + } + error "tm_version_required_canonical should have already returned a canonicalised versionspec - or produced an error with reason before this point" + } + } + # end tm_version... functions + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + + + # -- --- #https://stackoverflow.com/questions/17631269/whats-the-best-way-to-join-two-lists #DKF's 2013 recommendation of using list {*}$first {*}$second seems not to apply in 2024 @@ -1575,8 +1713,20 @@ namespace eval punk::lib { lremove $fromlist {*}$doomed } + #fix for tcl impl of struct::set::diff which doesn't dedupe + proc struct_set_diff_unique {A B} { + package require struct::set ;#require even if tcl impl - so the dependency isn't missed accidentally due to Loaded state of programmers machine. + if {[struct::set::Loaded] eq "tcl"} { + return [punk::lib::setdiff $A $B] + } else { + #use (presumably critcl) implementation for speed + return [struct::set difference $A $B] + } + } + + #non-dupe preserving - for consistency in dedupe behaviour we don't shortcircuit empty B - #consistent dedupe and order-maintenance of remaining items in A differentiate this from struct::set difference + #consistent dedupe and order-maintenance of remaining items in A differentiate this from struct::set difference (dedupes with critcl, doesn't with tcl implementation 2024) #also struct::set difference with critcl is faster proc setdiff {A B} { if {[llength $A] == 0} {return {}} @@ -2387,7 +2537,7 @@ namespace eval punk::lib { set stdin_state [fconfigure stdin] if {[catch { package require punk::console - set console_raw [set ::punk::console::is_raw] + set console_raw [tsv::get console is_raw] } err_console]} { #assume normal line mode set console_raw 0 @@ -3032,6 +3182,11 @@ namespace eval punk::lib { proc objclone {obj} { append obj2 $obj {} } + proc set_clone {varname obj} { + #used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_clone varnmame $val] + append obj2 $obj {} + uplevel 1 [list set $varname $obj2] + } @@ -3175,7 +3330,7 @@ tcl::namespace::eval punk::lib::system { #[para] Internal functions that are not part of the API #[list_begin definitions] - proc has_script_var_bug {} { + proc has_tclbug_script_var {} { set script {set j [list spud] ; list} append script \n uplevel #0 $script @@ -3194,7 +3349,15 @@ tcl::namespace::eval punk::lib::system { return false } } - proc has_safeinterp_compile_bug {{show 0}} { + + proc has_tclbug_list_quoting_emptyjoin {} { + #https://core.tcl-lang.org/tcl/tktview/e38dce74e2 + set v1 [list {*}[lindex #foo] {*}[]] ;#can return "#foo" instead of "{#foo}" under some beta 9 releases + set v2 [list #foo] ;#normal tcl list quoting for 1st element that looks like a comment -> "{#foo}" + return [expr {![string equal $v1 $v2]}] ;#if they're not equal - we have the bug. + } + + proc has_tclbug_safeinterp_compile {{show 0}} { #ensemble calls within safe interp not compiled namespace eval [namespace current]::testcompile { proc ensembletest {} {string index a 0} diff --git a/src/bootsupport/modules/punk/mix/base-0.1.tm b/src/bootsupport/modules/punk/mix/base-0.1.tm index 806b172e..dfdc71f9 100644 --- a/src/bootsupport/modules/punk/mix/base-0.1.tm +++ b/src/bootsupport/modules/punk/mix/base-0.1.tm @@ -473,13 +473,26 @@ namespace eval punk::mix::base { #set data [fileutil::cat -translation binary $filename] ;#no significant performance diff on windows - and doesn't handle win-illegal names zlib adler32 $data } - #zlib crc vie file-slurp + #zlib crc via file-slurp proc cksum_crc_file {filename} { package require zlib set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename] zlib crc $data } + proc cksum_md5_data {data} { + if {[package vsatisfies [package present md5] 2-]} { + return [md5::md5 -hex $data] + } else { + return [md5::md5 $data] + } + } + #fallback md5 via file-slurp - shouldn't be needed if have md5 2- + proc cksum_md5_file {filename} { + set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename] + cksum_md5_data $data + } + #required to be able to accept relative paths #for full cksum - using tar could reduce number of hashes to be made.. @@ -624,7 +637,11 @@ namespace eval punk::mix::base { } md5 { package require md5 - set cksum_command [list md5::md5 -hex -file] + if {[package vsatisfies [package present md5] 2- ] } { + set cksum_command [list md5::md5 -hex -file] + } else { + set cksum_comand [list cksum_md5_file] + } } cksum { package require cksum ;#tcllib @@ -637,7 +654,7 @@ namespace eval punk::mix::base { set cksum_command [list cksum_adler32_file] } sha3 - sha3-256 { - #todo - replace with something that doesn't call another process + #todo - replace with something that doesn't call another process - only if tcllibc not available! #set cksum_command [list apply {{file} {lindex [exec fossil sha3sum -256 $file] 0}}] set cksum_command [list $sha3_implementation 256] } @@ -684,7 +701,7 @@ namespace eval punk::mix::base { set sizeinfo "(file type $ftype - tarred size [punk::lib::format_number [file size $archivename]] bytes)" } set tsstart [clock millis] - puts -nonewline stdout "cksum_path: calculating cksum for $target $sizeinfo ... " + puts -nonewline stdout "cksum_path: calculating cksum using $opt_cksum_algorithm for $target $sizeinfo ... " set cksum [{*}$cksum_command $archivename] set tsend [clock millis] set ms [expr {$tsend - $tsstart}] diff --git a/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm index 856c9340..1d8d40e1 100644 --- a/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm @@ -271,7 +271,12 @@ namespace eval punk::mix::commandset::doc { #this case only came up because docgen used to path munge to long filenames - but left because we know there is a limit and renaming fixes it - even if it's ugly - but still allows doc generation. #review - if we're checking fname - should also test length of whole path and determine limits for tar package require md5 - set target_docname [md5::md5 -hex [encoding convertto utf-8 $fullpath]]_overlongfilename.man + if {[package vsatisfies [package present md5] 2- ] } { + set md5opt "-hex" + } else { + set md5opt "" + } + set target_docname [md5::md5 {*}$md5opt [encoding convertto utf-8 $fullpath]]_overlongfilename.man puts stderr "WARNING - overlong file name - renaming $fullpath" puts stderr " to [file dirname $fullpath]/$target_docname" } diff --git a/src/bootsupport/modules/punk/mix/util-0.1.0.tm b/src/bootsupport/modules/punk/mix/util-0.1.0.tm index aca7eeed..d1459369 100644 --- a/src/bootsupport/modules/punk/mix/util-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/util-0.1.0.tm @@ -261,6 +261,8 @@ namespace eval punk::mix::util { return } + # review punk::lib::tm_version.. functions + proc is_valid_tm_version {versionpart} { #Needs to be suitable for use with Tcl's 'package vcompare' if {![catch [list package vcompare $versionpart $versionpart]]} { diff --git a/src/bootsupport/modules/punk/nav/fs-0.1.0.tm b/src/bootsupport/modules/punk/nav/fs-0.1.0.tm index 426271a7..9cf44529 100644 --- a/src/bootsupport/modules/punk/nav/fs-0.1.0.tm +++ b/src/bootsupport/modules/punk/nav/fs-0.1.0.tm @@ -821,9 +821,12 @@ tcl::namespace::eval punk::nav::fs { set match_contents $opt_tailglob } } - puts stdout "searchbase: $searchbase searchspec:$searchspec" + #puts stdout "searchbase: $searchbase searchspec:$searchspec" - set in_vfs 0 + + #file attr //cookit:/ returns {-vfs 1 -handle {}} + #we will treat it differently for now - use generic handler REVIEW + set in_vfs 0 ;#we use this only for a vfs which is reported to have a mountpoint by vfs::filesystem info - not all that have -vfs 1 attr like cookit. if {[llength [package provide vfs]]} { foreach mount [vfs::filesystem info] { if {[punk::mix::base::lib::path_a_atorbelow_b $location $mount]} { @@ -849,22 +852,45 @@ tcl::namespace::eval punk::nav::fs { set listing [punk::du::lib::du_dirlisting_tclvfs $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] } else { set in_zipfs 0 - if {[info commands ::tcl::zipfs::mount] ne ""} { - if {[string match //zipfs:/* $location]} { - set in_zipfs 1 + set in_cookit 1 + set in_other_pseudovol 1 + switch -glob -- $location { + //zipfs:/* { + if {[info commands ::tcl::zipfs::mount] ne ""} { + set in_zipfs 1 + } + } + //cookit:/* { + set in_cookit 1 + } + default { + #handle 'other/unknown' that mounts at a volume-like path //pseudovol:/ + if {[regexp {//((?:(?!:|/).)+):/.*} $location _match pseudovol]} { + #pseudovol probably more than one char long + #we don't really expect something like //c:/ , but anyway, it's not the same as c:/ and for all we know someone could use that as a volume name? + set in_other_pseudovol 1 ;#flag so we don't use twapi - hope generic can handle it (uses tcl glob) + } else { + #we could use 'file attr' here to test if {-vfs 1} + #but it's an extra filesystem hit on all normal paths too (which can be expensive on some systems) + #instead for now we'll assume any reasonable vfs should have been found by vfs::filesystem::info or mounted as a pseudovolume + } + } - #dict for {zmount zpath} [zipfs mount] { - # if {[punk::mix::base::lib::path_a_atorbelow_b $location $zmount]} { - # set in_zipfs 1 - # break - # } - #} } + if {$in_zipfs} { #relative vs absolute? review - cwd valid for //zipfs:/ ?? - set listing [punk::du::lib::du_dirlisting_zipfs $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] + set listing [punk::du::lib::du_dirlisting_zipfs $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] + } elseif {$in_cookit} { + #seems to be a vfs - except it mounts on a pseudo-volume path //cookit:/ + #don't use twapi + #could possibly use du_dirlisting_tclvfs REVIEW + #files and folders are all returned with the -types hidden option for glob on windows + set listing [punk::du::lib::du_dirlisting_generic $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] + } elseif {$in_other} { + set listing [punk::du::lib::du_dirlisting_generic $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] } else { - set listing [punk::du::dirlisting $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] + set listing [punk::du::dirlisting $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] } } diff --git a/src/bootsupport/modules/punk/packagepreference-0.1.0.tm b/src/bootsupport/modules/punk/packagepreference-0.1.0.tm index d950eab4..e38c76c6 100644 --- a/src/bootsupport/modules/punk/packagepreference-0.1.0.tm +++ b/src/bootsupport/modules/punk/packagepreference-0.1.0.tm @@ -155,18 +155,26 @@ tcl::namespace::eval punk::packagepreference { if {[lindex $args 1] eq "-exact"} { set pkg [lindex $args 2] set vwant [lindex $args 3] - if {[set ver [package provide $pkg]] ne ""} { - if {$ver eq $vwant} { - return $vwant - } else { - #package already provided with a different version.. we will defer to underlying implementation to return the standard error - return [$COMMANDSTACKNEXT {*}$args] - } + if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} { + #although we could shortcircuit using vsatisfies to return the ver + #we should instead pass through to COMMANDSTACKNEXT so as not to interfere with whatever it does. + return [$COMMANDSTACKNEXT {*}$args] + + #if {$vwant eq "" || [$COMMANDSTACKNEXT vsatisfies $ver $vwant]} { + # return $ver + #} else { + # #package already provided with a different version.. we will defer to underlying implementation to return the standard error + # return [$COMMANDSTACKNEXT {*}$args] + #} } } else { set pkg [lindex $args 1] - if {[set ver [package provide $pkg]] ne ""} { - return $ver + set vwant [lindex $args 2] + if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} { + return [$COMMANDSTACKNEXT {*}$args] + #if {$vwant eq "" || [$COMMANDSTACKNEXT vsatisfies $ver $vwant]} { + # return $ver + #} } } if {[regexp {[A-Z]} $pkg]} { diff --git a/src/bootsupport/modules/punk/repl/codethread-0.1.0.tm b/src/bootsupport/modules/punk/repl/codethread-0.1.0.tm index 09b8a0be..39b5bf78 100644 --- a/src/bootsupport/modules/punk/repl/codethread-0.1.0.tm +++ b/src/bootsupport/modules/punk/repl/codethread-0.1.0.tm @@ -20,12 +20,12 @@ #*** !doctools #[manpage_begin shellspy_module_punk::repl::codethread 0 0.1.0] #[copyright "2024"] -#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[titledesc {Module repl codethread}] [comment {-- Name section and table of contents description --}] +#[moddesc {codethread for repl - root interpreter}] [comment {-- Description at end of page heading --}] #[require punk::repl::codethread] -#[keywords module] +#[keywords module repl] #[description] -#[para] - +#[para] This is part of the infrastructure required for the punk::repl to operate # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -131,11 +131,14 @@ tcl::namespace::eval punk::repl::codethread { # return "ok" #} + variable run_command_cache + proc is_running {} { variable running return $running } proc runscript {script} { + #puts stderr "->runscript" variable replthread_cond variable output_stdout "" @@ -169,9 +172,18 @@ tcl::namespace::eval punk::repl::codethread { #set errhandle [shellfilter::stack::item_tophandle stderr] #interp transfer "" $errhandle code - set scope [interp eval code [list set ::punk::ns::ns_current]] set status [catch { - interp eval code [list tcl::namespace::inscope $scope $script] + #shennanigans to keep compiled script around after call. + #otherwise when $script goes out of scope - internal rep of vars set in script changes. + #The shimmering may be no big deal(?) - but debug/analysis using tcl::unsupported::representation becomes impossible. + interp eval code [list ::punk::lib::set_clone ::codeinterp::clonescript $script] ;#like objclone + interp eval code { + lappend ::codeinterp::run_command_cache $::codeinterp::clonescript + if {[llength $::codeinterp::run_command_cache] > 2000} { + set ::codeinterp::run_command_cache [lrange $::codeinterp::run_command_cache 1750 end][unset ::codeinterp::run_command_cache] + } + tcl::namespace::inscope $::punk::ns::ns_current $::codeinterp::clonescript + } } result] diff --git a/src/bootsupport/modules/punk/repo-0.1.1.tm b/src/bootsupport/modules/punk/repo-0.1.1.tm index 4e0217b0..bc93a9c3 100644 --- a/src/bootsupport/modules/punk/repo-0.1.1.tm +++ b/src/bootsupport/modules/punk/repo-0.1.1.tm @@ -27,6 +27,11 @@ # # path/repo functions # + +#REVIEW punk::repo required early by punk boot script to find projectdir +#todo - split off basic find_project chain of functions to a smaller package and import as necessary here +#Then we can reduce early dependencies in punk boot + if {$::tcl_platform(platform) eq "windows"} { package require punk::winpath } else { diff --git a/src/bootsupport/modules/textblock-0.1.1.tm b/src/bootsupport/modules/textblock-0.1.1.tm index 96fb263d..b822b353 100644 --- a/src/bootsupport/modules/textblock-0.1.1.tm +++ b/src/bootsupport/modules/textblock-0.1.1.tm @@ -5280,8 +5280,8 @@ tcl::namespace::eval textblock { It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj" *values -min 1 -max 1 frametype -help "name from the predefined frametypes: - or an adhoc - }] + or an adhoc " + }] append spec \n "frametype -help \"A predefined \"" punk::args::get_dict $spec $args return @@ -6804,7 +6804,11 @@ tcl::namespace::eval textblock { if {$use_md5} { #package require md5 ;#already required at package load - set hash [md5::md5 -hex [encoding convertto utf-8 $hashables]] ;#need fast and unique to content - not cryptographic - review + if {[package vsatisfies [package present md5] 2- ] } { + set hash [md5::md5 -hex [encoding convertto utf-8 $hashables]] ;#need fast and unique to content - not cryptographic - review + } else { + set hash [md5::md5 [encoding convertto utf-8 $hashables]] + } } else { set hash $hashables } diff --git a/src/bootsupport/modules/textutil-0.9.tm b/src/bootsupport/modules/textutil-0.9.tm index 59258514..b18a5228 100644 --- a/src/bootsupport/modules/textutil-0.9.tm +++ b/src/bootsupport/modules/textutil-0.9.tm @@ -16,7 +16,7 @@ # ### ### ### ######### ######### ######### ## Requirements -package require Tcl 8.2 +package require Tcl 8.2- namespace eval ::textutil {}