78 changed files with 10404 additions and 769 deletions
@ -1,2 +1,2 @@ |
|||||||
if {![package vsatisfies [package provide Tcl] 8.2]} {return} |
if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} |
||||||
package ifneeded control 0.1.3 [list source [file join $dir control.tcl]] |
package ifneeded control 0.1.4 [list source [file join $dir control.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 |
||||||
@ -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 |
||||||
@ -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 |
||||||
@ -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]] |
||||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -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]] |
||||||
@ -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 |
||||||
@ -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 |
||||||
@ -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 |
||||||
|
} |
||||||
|
} |
||||||
@ -1,29 +1,25 @@ |
|||||||
if {![package vsatisfies [package provide Tcl] 8.2]} {return} |
if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} |
||||||
package ifneeded struct 2.1 [list source [file join $dir struct.tcl]] |
package ifneeded struct 2.2 [list source [file join $dir struct.tcl]] |
||||||
package ifneeded struct 1.4 [list source [file join $dir struct1.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::queue 1.4.6 [list source [file join $dir queue.tcl]] |
||||||
package ifneeded struct::stack 1.5.3 [list source [file join $dir stack.tcl]] |
package ifneeded struct::stack 1.5.4 [list source [file join $dir stack.tcl]] |
||||||
package ifneeded struct::tree 2.1.2 [list source [file join $dir tree.tcl]] |
package ifneeded struct::tree 2.1.3 [list source [file join $dir tree.tcl]] |
||||||
package ifneeded struct::pool 1.2.3 [list source [file join $dir pool.tcl]] |
package ifneeded struct::pool 1.2.4 [list source [file join $dir pool.tcl]] |
||||||
package ifneeded struct::record 1.2.2 [list source [file join $dir record.tcl]] |
package ifneeded struct::record 1.2.3 [list source [file join $dir record.tcl]] |
||||||
package ifneeded struct::set 2.2.3 [list source [file join $dir sets.tcl]] |
package ifneeded struct::set 2.2.4 [list source [file join $dir sets.tcl]] |
||||||
package ifneeded struct::prioqueue 1.4 [list source [file join $dir prioqueue.tcl]] |
package ifneeded struct::prioqueue 1.5 [list source [file join $dir prioqueue.tcl]] |
||||||
package ifneeded struct::skiplist 1.3 [list source [file join $dir skiplist.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::graph 1.2.2 [list source [file join $dir graph1.tcl]] |
||||||
package ifneeded struct::tree 1.2.2 [list source [file join $dir tree1.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.6 [list source [file join $dir list.tcl]] |
||||||
package ifneeded struct::list 1.8.5 [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::list::test 1.8.4 [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::graph 2.4.3 [list source [file join $dir graph.tcl]] |
package ifneeded struct::map 1.1 [list source [file join $dir map.tcl]] |
||||||
package ifneeded struct::map 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]] |
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]] |
||||||
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]] |
|
||||||
|
|||||||
@ -1,13 +1,13 @@ |
|||||||
if {![package vsatisfies [package provide Tcl] 8.4]} return |
if {![package vsatisfies [package provide Tcl] 8.5 9]} return |
||||||
package ifneeded term 0.1 [list source [file join $dir term.tcl]] |
package ifneeded term 0.2 [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 0.3 [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::attr 0.2 [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::ctrl 0.4 [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::code::macros 0.2 [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::ctrl::unix 0.1.2 [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::ansi::send 0.3 [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::menu 0.2 [list source [file join $dir imenu.tcl]] |
||||||
package ifneeded term::interact::pager 0.1 [list source [file join $dir ipager.tcl]] |
package ifneeded term::interact::pager 0.2 [list source [file join $dir ipager.tcl]] |
||||||
package ifneeded term::receive 0.1 [list source [file join $dir receive.tcl]] |
package ifneeded term::receive 0.2 [list source [file join $dir receive.tcl]] |
||||||
package ifneeded term::receive::bind 0.1 [list source [file join $dir bind.tcl]] |
package ifneeded term::receive::bind 0.2 [list source [file join $dir bind.tcl]] |
||||||
package ifneeded term::send 0.1 [list source [file join $dir send.tcl]] |
package ifneeded term::send 0.2 [list source [file join $dir send.tcl]] |
||||||
|
|||||||
Loading…
Reference in new issue