78 changed files with 10404 additions and 769 deletions
@ -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]] |
||||
|
||||
@ -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} |
||||
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]] |
||||
|
||||
@ -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]] |
||||
|
||||
Loading…
Reference in new issue