52 changed files with 6377 additions and 1663 deletions
@ -1,207 +0,0 @@
|
||||
# -*- 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.4 |
||||
|
||||
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.1 |
||||
return |
||||
@ -1,28 +0,0 @@
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
# (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.1 |
||||
@ -1,645 +0,0 @@
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
# (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.3 |
||||
@ -1,74 +0,0 @@
|
||||
# paths.tcl -- |
||||
# |
||||
# Manage lists of search paths. |
||||
# |
||||
# Copyright (c) 2009-2019 Andreas Kupries <andreas_kupries@sourceforge.net> |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
|
||||
# Each object instance manages a list of paths. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requisites |
||||
|
||||
package require Tcl 8.4 |
||||
package require snit |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## API |
||||
|
||||
snit::type ::fileutil::paths { |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Options :: None |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Creation, destruction |
||||
|
||||
# Default constructor. |
||||
# Default destructor. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Methods :: Querying and manipulating the list of paths. |
||||
|
||||
method paths {} { |
||||
return $mypaths |
||||
} |
||||
|
||||
method add {path} { |
||||
set pos [lsearch $mypaths $path] |
||||
if {$pos >= 0 } return |
||||
lappend mypaths $path |
||||
return |
||||
} |
||||
|
||||
method remove {path} { |
||||
set pos [lsearch $mypaths $path] |
||||
if {$pos < 0} return |
||||
set mypaths [lreplace $mypaths $pos $pos] |
||||
return |
||||
} |
||||
|
||||
method clear {} { |
||||
set mypaths {} |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Internal methods :: None |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## State :: List of paths. |
||||
|
||||
variable mypaths {} |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide fileutil::paths 1 |
||||
return |
||||
@ -1,504 +0,0 @@
|
||||
# traverse.tcl -- |
||||
# |
||||
# Directory traversal. |
||||
# |
||||
# Copyright (c) 2006-2015 by Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
|
||||
package require Tcl 8.3 |
||||
|
||||
# OO core |
||||
if {[package vsatisfies [package present Tcl] 8.5]} { |
||||
# Use new Tcl 8.5a6+ features to specify the allowed packages. |
||||
# We can use anything above 1.3. This means v2 as well. |
||||
package require snit 1.3- |
||||
} else { |
||||
# For Tcl 8.{3,4} only snit1 of a suitable patchlevel is possible. |
||||
package require snit 1.3 |
||||
} |
||||
package require control ; # Helpers for control structures |
||||
package require fileutil ; # -> fullnormalize |
||||
|
||||
snit::type ::fileutil::traverse { |
||||
|
||||
# Incremental directory traversal. |
||||
|
||||
# API |
||||
# create %AUTO% basedirectory options... -> object |
||||
# next filevar -> boolean |
||||
# foreach filevar script |
||||
# files -> list (path ...) |
||||
|
||||
# Options |
||||
# -prefilter command-prefix |
||||
# -filter command-prefix |
||||
# -errorcmd command-prefix |
||||
|
||||
# Use cases |
||||
# |
||||
# (a) Basic incremental |
||||
# - Create and configure a traversal object. |
||||
# - Execute 'next' to retrieve one path at a time, |
||||
# until the command returns False, signaling that |
||||
# the iterator has exhausted the supply of paths. |
||||
# (The path is stored in the named variable). |
||||
# |
||||
# The execution of 'next' can be done in a loop, or via event |
||||
# processing. |
||||
|
||||
# (b) Basic loop |
||||
# - Create and configure a traversal object. |
||||
# - Run a script for each path, using 'foreach'. |
||||
# This is a convenient standard wrapper around 'next'. |
||||
# |
||||
# The loop properly handles all possible Tcl result codes. |
||||
|
||||
# (c) Non-incremental, non-looping. |
||||
# - Create and configure a traversal object. |
||||
# - Retrieve a list of all paths via 'files'. |
||||
|
||||
# The -prefilter callback is executed for directories. Its result |
||||
# determines if the traverser recurses into the directory or not. |
||||
# The default is to always recurse into all directories. The call- |
||||
# back is invoked with a single argument, the path of the |
||||
# directory. |
||||
# |
||||
# The -filter callback is executed for all paths. Its result |
||||
# determines if the current path is a valid result, and returned |
||||
# by 'next'. The default is to accept all paths as valid. The |
||||
# callback is invoked with a single argument, the path to check. |
||||
|
||||
# The -errorcmd callback is executed for all paths the traverser |
||||
# has trouble with. Like being unable to cd into them, get their |
||||
# status, etc. The default is to ignore any such problems. The |
||||
# callback is invoked with a two arguments, the path for which the |
||||
# error occured, and the error message. Errors thrown by the |
||||
# filter callbacks are handled through this callback too. Errors |
||||
# thrown by the error callback itself are not caught and ignored, |
||||
# but allowed to pass to the caller, usually of 'next'. |
||||
|
||||
# Note: Low-level functionality, version and platform dependent is |
||||
# implemented in procedures, and conditioally defined for optimal |
||||
# use of features, etc. ... |
||||
|
||||
# Note: Traversal is done in depth-first pre-order. |
||||
|
||||
# Note: The options are handled only during |
||||
# construction. Afterward they are read-only and attempts to |
||||
# modify them will cause the system to throw errors. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Implementation |
||||
|
||||
option -filter -default {} -readonly 1 |
||||
option -prefilter -default {} -readonly 1 |
||||
option -errorcmd -default {} -readonly 1 |
||||
|
||||
constructor {basedir args} { |
||||
set _base $basedir |
||||
$self configurelist $args |
||||
return |
||||
} |
||||
|
||||
method files {} { |
||||
set files {} |
||||
$self foreach f {lappend files $f} |
||||
return $files |
||||
} |
||||
|
||||
method foreach {fvar body} { |
||||
upvar 1 $fvar currentfile |
||||
|
||||
# (Re-)initialize the traversal state on every call. |
||||
$self Init |
||||
|
||||
while {[$self next currentfile]} { |
||||
set code [catch {uplevel 1 $body} result] |
||||
|
||||
# decide what to do upon the return code: |
||||
# |
||||
# 0 - the body executed successfully |
||||
# 1 - the body raised an error |
||||
# 2 - the body invoked [return] |
||||
# 3 - the body invoked [break] |
||||
# 4 - the body invoked [continue] |
||||
# everything else - return and pass on the results |
||||
# |
||||
switch -exact -- $code { |
||||
0 {} |
||||
1 { |
||||
return -errorinfo [::control::ErrorInfoAsCaller uplevel foreach] \ |
||||
-errorcode $::errorCode -code error $result |
||||
} |
||||
3 { |
||||
# FRINK: nocheck |
||||
return |
||||
} |
||||
4 {} |
||||
default { |
||||
return -code $code $result |
||||
} |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
method next {fvar} { |
||||
upvar 1 $fvar currentfile |
||||
|
||||
# Initialize on first call. |
||||
if {!$_init} { |
||||
$self Init |
||||
} |
||||
|
||||
# We (still) have valid paths in the result stack, return the |
||||
# next one. |
||||
|
||||
if {[llength $_results]} { |
||||
set top [lindex $_results end] |
||||
set _results [lreplace $_results end end] |
||||
set currentfile $top |
||||
return 1 |
||||
} |
||||
|
||||
# Take the next directory waiting in the processing stack and |
||||
# fill the result stack with all valid files and sub- |
||||
# directories contained in it. Extend the processing queue |
||||
# with all sub-directories not yet seen already (!circular |
||||
# symlinks) and accepted by the prefilter. We stop iterating |
||||
# when we either have no directories to process anymore, or |
||||
# the result stack contains at least one path we can return. |
||||
|
||||
while {[llength $_pending]} { |
||||
set top [lindex $_pending end] |
||||
set _pending [lreplace $_pending end end] |
||||
|
||||
# Directory accessible? Skip if not. |
||||
if {![ACCESS $top]} { |
||||
Error $top "Inacessible directory" |
||||
continue |
||||
} |
||||
|
||||
# Expand the result stack with all files in the directory, |
||||
# modulo filtering. |
||||
|
||||
foreach f [GLOBF $top] { |
||||
if {![Valid $f]} continue |
||||
lappend _results $f |
||||
} |
||||
|
||||
# Expand the result stack with all sub-directories in the |
||||
# directory, modulo filtering. Further expand the |
||||
# processing stack with the same directories, if not seen |
||||
# yet and modulo pre-filtering. |
||||
|
||||
foreach f [GLOBD $top] { |
||||
if { |
||||
[string equal [file tail $f] "."] || |
||||
[string equal [file tail $f] ".."] |
||||
} continue |
||||
|
||||
if {[Valid $f]} { |
||||
lappend _results $f |
||||
} |
||||
|
||||
Enter $top $f |
||||
if {[Cycle $f]} continue |
||||
|
||||
if {[Recurse $f]} { |
||||
lappend _pending $f |
||||
} |
||||
} |
||||
|
||||
# Stop expanding if we have paths to return. |
||||
|
||||
if {[llength $_results]} { |
||||
set top [lindex $_results end] |
||||
set _results [lreplace $_results end end] |
||||
set currentfile $top |
||||
return 1 |
||||
} |
||||
} |
||||
|
||||
# Allow re-initialization with next call. |
||||
|
||||
set _init 0 |
||||
return 0 |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Traversal state |
||||
|
||||
# * Initialization flag. Checked in 'next', reset by next when no |
||||
# more files are available. Set in 'Init'. |
||||
# * Base directory (or file) to start the traversal from. |
||||
# * Stack of prefiltered unknown directories waiting for |
||||
# processing, i.e. expansion (TOP at end). |
||||
# * Stack of valid paths waiting to be returned as results. |
||||
# * Set of directories already visited (normalized paths), for |
||||
# detection of circular symbolic links. |
||||
|
||||
variable _init 0 ; # Initialization flag. |
||||
variable _base {} ; # Base directory. |
||||
variable _pending {} ; # Processing stack. |
||||
variable _results {} ; # Result stack. |
||||
|
||||
# sym link handling (to break cycles, while allowing the following of non-cycle links). |
||||
# Notes |
||||
# - path parent tracking is lexical. |
||||
# - path identity tracking is based on the normalized path, i.e. the path with all |
||||
# symlinks resolved. |
||||
# Maps |
||||
# - path -> parent (easier to follow the list than doing dirname's) |
||||
# - path -> normalized (cache to avoid redundant calls of fullnormalize) |
||||
# cycle <=> A parent's normalized form (NF) is identical to the current path's NF |
||||
|
||||
variable _parent -array {} |
||||
variable _norm -array {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Internal helpers. |
||||
|
||||
proc Enter {parent path} { |
||||
#puts ___E|$path |
||||
upvar 1 _parent _parent _norm _norm |
||||
set _parent($path) $parent |
||||
set _norm($path) [fileutil::fullnormalize $path] |
||||
} |
||||
|
||||
proc Cycle {path} { |
||||
upvar 1 _parent _parent _norm _norm |
||||
set nform $_norm($path) |
||||
set paren $_parent($path) |
||||
while {$paren ne {}} { |
||||
if {$_norm($paren) eq $nform} { return yes } |
||||
set paren $_parent($paren) |
||||
} |
||||
return no |
||||
} |
||||
|
||||
method Init {} { |
||||
array unset _parent * |
||||
array unset _norm * |
||||
|
||||
# Path ok as result? |
||||
if {[Valid $_base]} { |
||||
lappend _results $_base |
||||
} |
||||
|
||||
# Expansion allowed by prefilter? |
||||
if {[file isdirectory $_base] && [Recurse $_base]} { |
||||
Enter {} $_base |
||||
lappend _pending $_base |
||||
} |
||||
|
||||
# System is set up now. |
||||
set _init 1 |
||||
return |
||||
} |
||||
|
||||
proc Valid {path} { |
||||
#puts ___V|$path |
||||
upvar 1 options options |
||||
if {![llength $options(-filter)]} {return 1} |
||||
set path [file normalize $path] |
||||
set code [catch {uplevel \#0 [linsert $options(-filter) end $path]} valid] |
||||
if {!$code} {return $valid} |
||||
Error $path $valid |
||||
return 0 |
||||
} |
||||
|
||||
proc Recurse {path} { |
||||
#puts ___X|$path |
||||
upvar 1 options options _norm _norm |
||||
if {![llength $options(-prefilter)]} {return 1} |
||||
set path [file normalize $path] |
||||
set code [catch {uplevel \#0 [linsert $options(-prefilter) end $path]} valid] |
||||
if {!$code} {return $valid} |
||||
Error $path $valid |
||||
return 0 |
||||
} |
||||
|
||||
proc Error {path msg} { |
||||
upvar 1 options options |
||||
if {![llength $options(-errorcmd)]} return |
||||
set path [file normalize $path] |
||||
uplevel \#0 [linsert $options(-errorcmd) end $path $msg] |
||||
return |
||||
} |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
# The next three helper commands for the traverser depend strongly on |
||||
# the version of Tcl, and partially on the platform. |
||||
|
||||
# 1. In Tcl 8.3 using -types f will return only true files, but not |
||||
# links to files. This changed in 8.4+ where links to files are |
||||
# returned as well. So for 8.3 we have to handle the links |
||||
# separately (-types l) and also filter on our own. |
||||
# Note that Windows file links are hard links which are reported by |
||||
# -types f, but not -types l, so we can optimize that for the two |
||||
# platforms. |
||||
# |
||||
# 2. In Tcl 8.3 we also have a crashing bug in glob (SIGABRT, "stat on |
||||
# a known file") when trying to perform 'glob -types {hidden f}' on |
||||
# a directory without e'x'ecute permissions. We code around by |
||||
# testing if we can cd into the directory (stat might return enough |
||||
# information too (mode), but possibly also not portable). |
||||
# |
||||
# For Tcl 8.2 and 8.4+ glob simply delivers an empty result |
||||
# (-nocomplain), without crashing. For them this command is defined |
||||
# so that the bytecode compiler removes it from the bytecode. |
||||
# |
||||
# This bug made the ACCESS helper necessary. |
||||
# We code around the problem by testing if we can cd into the |
||||
# directory (stat might return enough information too (mode), but |
||||
# possibly also not portable). |
||||
|
||||
if {[package vsatisfies [package present Tcl] 8.5]} { |
||||
# Tcl 8.5+. |
||||
# We have to check readability of "current" on our own, glob |
||||
# changed to error out instead of returning nothing. |
||||
|
||||
proc ::fileutil::traverse::ACCESS {args} {return 1} |
||||
|
||||
proc ::fileutil::traverse::GLOBF {current} { |
||||
if {![file readable $current] || |
||||
[BadLink $current]} { |
||||
return {} |
||||
} |
||||
|
||||
set res [lsort -unique [concat \ |
||||
[glob -nocomplain -directory $current -types f -- *] \ |
||||
[glob -nocomplain -directory $current -types {hidden f} -- *]]] |
||||
|
||||
# Look for broken links (They are reported as neither file nor directory). |
||||
foreach l [lsort -unique [concat \ |
||||
[glob -nocomplain -directory $current -types l -- *] \ |
||||
[glob -nocomplain -directory $current -types {hidden l} -- *]]] { |
||||
if {[file isfile $l]} continue |
||||
if {[file isdirectory $l]} continue |
||||
lappend res $l |
||||
} |
||||
return [lsort -unique $res] |
||||
} |
||||
|
||||
proc ::fileutil::traverse::GLOBD {current} { |
||||
if {![file readable $current] || |
||||
[BadLink $current]} { |
||||
return {} |
||||
} |
||||
|
||||
lsort -unique [concat \ |
||||
[glob -nocomplain -directory $current -types d -- *] \ |
||||
[glob -nocomplain -directory $current -types {hidden d} -- *]] |
||||
} |
||||
|
||||
proc ::fileutil::traverse::BadLink {current} { |
||||
if {[file type $current] ne "link"} { return no } |
||||
|
||||
set dst [file join [file dirname $current] [file readlink $current]] |
||||
|
||||
if {![file exists $dst] || |
||||
![file readable $dst]} { |
||||
return yes |
||||
} |
||||
|
||||
return no |
||||
} |
||||
|
||||
} elseif {[package vsatisfies [package present Tcl] 8.4]} { |
||||
# Tcl 8.4+. |
||||
# (Ad 1) We have -directory, and -types, |
||||
# (Ad 2) Links are returned for -types f/d if they refer to files/dirs. |
||||
# (Ad 3) No bug to code around |
||||
|
||||
proc ::fileutil::traverse::ACCESS {args} {return 1} |
||||
|
||||
proc ::fileutil::traverse::GLOBF {current} { |
||||
set res [concat \ |
||||
[glob -nocomplain -directory $current -types f -- *] \ |
||||
[glob -nocomplain -directory $current -types {hidden f} -- *]] |
||||
|
||||
# Look for broken links (They are reported as neither file nor directory). |
||||
foreach l [concat \ |
||||
[glob -nocomplain -directory $current -types l -- *] \ |
||||
[glob -nocomplain -directory $current -types {hidden l} -- *] ] { |
||||
if {[file isfile $l]} continue |
||||
if {[file isdirectory $l]} continue |
||||
lappend res $l |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
proc ::fileutil::traverse::GLOBD {current} { |
||||
concat \ |
||||
[glob -nocomplain -directory $current -types d -- *] \ |
||||
[glob -nocomplain -directory $current -types {hidden d} -- *] |
||||
} |
||||
|
||||
} else { |
||||
# 8.3. |
||||
# (Ad 1) We have -directory, and -types, |
||||
# (Ad 2) Links are NOT returned for -types f/d, collect separately. |
||||
# No symbolic file links on Windows. |
||||
# (Ad 3) Bug to code around. |
||||
|
||||
proc ::fileutil::traverse::ACCESS {current} { |
||||
if {[catch { |
||||
set h [pwd] ; cd $current ; cd $h |
||||
}]} {return 0} |
||||
return 1 |
||||
} |
||||
|
||||
if {[string equal $::tcl_platform(platform) windows]} { |
||||
proc ::fileutil::traverse::GLOBF {current} { |
||||
concat \ |
||||
[glob -nocomplain -directory $current -types f -- *] \ |
||||
[glob -nocomplain -directory $current -types {hidden f} -- *]] |
||||
} |
||||
} else { |
||||
proc ::fileutil::traverse::GLOBF {current} { |
||||
set l [concat \ |
||||
[glob -nocomplain -directory $current -types f -- *] \ |
||||
[glob -nocomplain -directory $current -types {hidden f} -- *]] |
||||
|
||||
foreach x [concat \ |
||||
[glob -nocomplain -directory $current -types l -- *] \ |
||||
[glob -nocomplain -directory $current -types {hidden l} -- *]] { |
||||
if {[file isdirectory $x]} continue |
||||
# We have now accepted files, links to files, and broken links. |
||||
lappend l $x |
||||
} |
||||
|
||||
return $l |
||||
} |
||||
} |
||||
|
||||
proc ::fileutil::traverse::GLOBD {current} { |
||||
set l [concat \ |
||||
[glob -nocomplain -directory $current -types d -- *] \ |
||||
[glob -nocomplain -directory $current -types {hidden d} -- *]] |
||||
|
||||
foreach x [concat \ |
||||
[glob -nocomplain -directory $current -types l -- *] \ |
||||
[glob -nocomplain -directory $current -types {hidden l} -- *]] { |
||||
if {![file isdirectory $x]} continue |
||||
lappend l $x |
||||
} |
||||
|
||||
return $l |
||||
} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide fileutil::traverse 0.6 |
||||
@ -0,0 +1,2 @@
|
||||
|
||||
This folder is for tcl packages which use the pkgIndex.tcl system to load, and are required by boot or make related scripts in src. |
||||
@ -0,0 +1,933 @@
|
||||
# cmdline.tcl -- |
||||
# |
||||
# This package provides a utility for parsing command line |
||||
# arguments that are processed by our various applications. |
||||
# It also includes a utility routine to determine the |
||||
# application name for use in command line errors. |
||||
# |
||||
# Copyright (c) 1998-2000 by Ajuba Solutions. |
||||
# Copyright (c) 2001-2015 by Andreas Kupries <andreas_kupries@users.sf.net>. |
||||
# Copyright (c) 2003 by David N. Welton <davidw@dedasys.com> |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
|
||||
package require Tcl 8.5- |
||||
package provide cmdline 1.5.2 |
||||
|
||||
namespace eval ::cmdline { |
||||
namespace export getArgv0 getopt getKnownOpt getfiles getoptions \ |
||||
getKnownOptions usage |
||||
} |
||||
|
||||
# ::cmdline::getopt -- |
||||
# |
||||
# The cmdline::getopt works in a fashion like the standard |
||||
# C based getopt function. Given an option string and a |
||||
# pointer to an array or args this command will process the |
||||
# first argument and return info on how to proceed. |
||||
# |
||||
# Arguments: |
||||
# argvVar Name of the argv list that you |
||||
# want to process. If options are found the |
||||
# arg list is modified and the processed arguments |
||||
# are removed from the start of the list. |
||||
# optstring A list of command options that the application |
||||
# will accept. If the option ends in ".arg" the |
||||
# getopt routine will use the next argument as |
||||
# an argument to the option. Otherwise the option |
||||
# is a boolean that is set to 1 if present. |
||||
# optVar The variable pointed to by optVar |
||||
# contains the option that was found (without the |
||||
# leading '-' and without the .arg extension). |
||||
# valVar Upon success, the variable pointed to by valVar |
||||
# contains the value for the specified option. |
||||
# This value comes from the command line for .arg |
||||
# options, otherwise the value is 1. |
||||
# If getopt fails, the valVar is filled with an |
||||
# error message. |
||||
# |
||||
# Results: |
||||
# The getopt function returns 1 if an option was found, 0 if no more |
||||
# options were found, and -1 if an error occurred. |
||||
|
||||
proc ::cmdline::getopt {argvVar optstring optVar valVar} { |
||||
upvar 1 $argvVar argsList |
||||
upvar 1 $optVar option |
||||
upvar 1 $valVar value |
||||
|
||||
set result [getKnownOpt argsList $optstring option value] |
||||
|
||||
if {$result < 0} { |
||||
# Collapse unknown-option error into any-other-error result. |
||||
set result -1 |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
# ::cmdline::getKnownOpt -- |
||||
# |
||||
# The cmdline::getKnownOpt works in a fashion like the standard |
||||
# C based getopt function. Given an option string and a |
||||
# pointer to an array or args this command will process the |
||||
# first argument and return info on how to proceed. |
||||
# |
||||
# Arguments: |
||||
# argvVar Name of the argv list that you |
||||
# want to process. If options are found the |
||||
# arg list is modified and the processed arguments |
||||
# are removed from the start of the list. Note that |
||||
# unknown options and the args that follow them are |
||||
# left in this list. |
||||
# optstring A list of command options that the application |
||||
# will accept. If the option ends in ".arg" the |
||||
# getopt routine will use the next argument as |
||||
# an argument to the option. Otherwise the option |
||||
# is a boolean that is set to 1 if present. |
||||
# optVar The variable pointed to by optVar |
||||
# contains the option that was found (without the |
||||
# leading '-' and without the .arg extension). |
||||
# valVar Upon success, the variable pointed to by valVar |
||||
# contains the value for the specified option. |
||||
# This value comes from the command line for .arg |
||||
# options, otherwise the value is 1. |
||||
# If getopt fails, the valVar is filled with an |
||||
# error message. |
||||
# |
||||
# Results: |
||||
# The getKnownOpt function returns 1 if an option was found, |
||||
# 0 if no more options were found, -1 if an unknown option was |
||||
# encountered, and -2 if any other error occurred. |
||||
|
||||
proc ::cmdline::getKnownOpt {argvVar optstring optVar valVar} { |
||||
upvar 1 $argvVar argsList |
||||
upvar 1 $optVar option |
||||
upvar 1 $valVar value |
||||
|
||||
# default settings for a normal return |
||||
set value "" |
||||
set option "" |
||||
set result 0 |
||||
|
||||
# check if we're past the end of the args list |
||||
if {[llength $argsList] != 0} { |
||||
|
||||
# if we got -- or an option that doesn't begin with -, return (skipping |
||||
# the --). otherwise process the option arg. |
||||
switch -glob -- [set arg [lindex $argsList 0]] { |
||||
"--" { |
||||
set argsList [lrange $argsList 1 end] |
||||
} |
||||
"--*" - |
||||
"-*" { |
||||
set option [string range $arg 1 end] |
||||
if {[string equal [string range $option 0 0] "-"]} { |
||||
set option [string range $arg 2 end] |
||||
} |
||||
|
||||
# support for format: [-]-option=value |
||||
set idx [string first "=" $option 1] |
||||
if {$idx != -1} { |
||||
set _val [string range $option [expr {$idx+1}] end] |
||||
set option [string range $option 0 [expr {$idx-1}]] |
||||
} |
||||
|
||||
if {[lsearch -exact $optstring $option] != -1} { |
||||
# Booleans are set to 1 when present |
||||
set value 1 |
||||
set result 1 |
||||
set argsList [lrange $argsList 1 end] |
||||
} elseif {[lsearch -exact $optstring "$option.arg"] != -1} { |
||||
set result 1 |
||||
set argsList [lrange $argsList 1 end] |
||||
|
||||
if {[info exists _val]} { |
||||
set value $_val |
||||
} elseif {[llength $argsList]} { |
||||
set value [lindex $argsList 0] |
||||
set argsList [lrange $argsList 1 end] |
||||
} else { |
||||
set value "Option \"$option\" requires an argument" |
||||
set result -2 |
||||
} |
||||
} else { |
||||
# Unknown option. |
||||
set value "Illegal option \"-$option\"" |
||||
set result -1 |
||||
} |
||||
} |
||||
default { |
||||
# Skip ahead |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
|
||||
# ::cmdline::getoptions -- |
||||
# |
||||
# Process a set of command line options, filling in defaults |
||||
# for those not specified. This also generates an error message |
||||
# that lists the allowed flags if an incorrect flag is specified. |
||||
# |
||||
# Arguments: |
||||
# argvVar The name of the argument list, typically argv. |
||||
# We remove all known options and their args from it. |
||||
# In other words, after the call to this command the |
||||
# referenced variable contains only the non-options, |
||||
# and unknown options. |
||||
# optlist A list-of-lists where each element specifies an option |
||||
# in the form: |
||||
# (where flag takes no argument) |
||||
# flag comment |
||||
# |
||||
# (or where flag takes an argument) |
||||
# flag default comment |
||||
# |
||||
# If flag ends in ".arg" then the value is taken from the |
||||
# command line. Otherwise it is a boolean and appears in |
||||
# the result if present on the command line. If flag ends |
||||
# in ".secret", it will not be displayed in the usage. |
||||
# usage Text to include in the usage display. Defaults to |
||||
# "options:" |
||||
# |
||||
# Results |
||||
# Name value pairs suitable for using with array set. |
||||
# A modified `argvVar`. |
||||
|
||||
proc ::cmdline::getoptions {argvVar optlist {usage options:}} { |
||||
upvar 1 $argvVar argv |
||||
|
||||
set opts [GetOptionDefaults $optlist result] |
||||
|
||||
set argc [llength $argv] |
||||
while {[set err [getopt argv $opts opt arg]]} { |
||||
if {$err < 0} { |
||||
set result(?) "" |
||||
break |
||||
} |
||||
set result($opt) $arg |
||||
} |
||||
if {[info exist result(?)] || [info exists result(help)]} { |
||||
Error [usage $optlist $usage] USAGE |
||||
} |
||||
return [array get result] |
||||
} |
||||
|
||||
# ::cmdline::getKnownOptions -- |
||||
# |
||||
# Process a set of command line options, filling in defaults |
||||
# for those not specified. This ignores unknown flags, but generates |
||||
# an error message that lists the correct usage if a known option |
||||
# is used incorrectly. |
||||
# |
||||
# Arguments: |
||||
# argvVar The name of the argument list, typically argv. This |
||||
# We remove all known options and their args from it. |
||||
# In other words, after the call to this command the |
||||
# referenced variable contains only the non-options, |
||||
# and unknown options. |
||||
# optlist A list-of-lists where each element specifies an option |
||||
# in the form: |
||||
# flag default comment |
||||
# If flag ends in ".arg" then the value is taken from the |
||||
# command line. Otherwise it is a boolean and appears in |
||||
# the result if present on the command line. If flag ends |
||||
# in ".secret", it will not be displayed in the usage. |
||||
# usage Text to include in the usage display. Defaults to |
||||
# "options:" |
||||
# |
||||
# Results |
||||
# Name value pairs suitable for using with array set. |
||||
# A modified `argvVar`. |
||||
|
||||
proc ::cmdline::getKnownOptions {argvVar optlist {usage options:}} { |
||||
upvar 1 $argvVar argv |
||||
|
||||
set opts [GetOptionDefaults $optlist result] |
||||
|
||||
# As we encounter them, keep the unknown options and their |
||||
# arguments in this list. Before we return from this procedure, |
||||
# we'll prepend these args to the argList so that the application |
||||
# doesn't lose them. |
||||
|
||||
set unknownOptions [list] |
||||
|
||||
set argc [llength $argv] |
||||
while {[set err [getKnownOpt argv $opts opt arg]]} { |
||||
if {$err == -1} { |
||||
# Unknown option. |
||||
|
||||
# Skip over any non-option items that follow it. |
||||
# For now, add them to the list of unknownOptions. |
||||
lappend unknownOptions [lindex $argv 0] |
||||
set argv [lrange $argv 1 end] |
||||
while {([llength $argv] != 0) \ |
||||
&& ![string match "-*" [lindex $argv 0]]} { |
||||
lappend unknownOptions [lindex $argv 0] |
||||
set argv [lrange $argv 1 end] |
||||
} |
||||
} elseif {$err == -2} { |
||||
set result(?) "" |
||||
break |
||||
} else { |
||||
set result($opt) $arg |
||||
} |
||||
} |
||||
|
||||
# Before returning, prepend the any unknown args back onto the |
||||
# argList so that the application doesn't lose them. |
||||
set argv [concat $unknownOptions $argv] |
||||
|
||||
if {[info exist result(?)] || [info exists result(help)]} { |
||||
Error [usage $optlist $usage] USAGE |
||||
} |
||||
return [array get result] |
||||
} |
||||
|
||||
# ::cmdline::GetOptionDefaults -- |
||||
# |
||||
# This internal procedure processes the option list (that was passed to |
||||
# the getopt or getKnownOpt procedure). The defaultArray gets an index |
||||
# for each option in the option list, the value of which is the option's |
||||
# default value. |
||||
# |
||||
# Arguments: |
||||
# optlist A list-of-lists where each element specifies an option |
||||
# in the form: |
||||
# flag default comment |
||||
# If flag ends in ".arg" then the value is taken from the |
||||
# command line. Otherwise it is a boolean and appears in |
||||
# the result if present on the command line. If flag ends |
||||
# in ".secret", it will not be displayed in the usage. |
||||
# defaultArrayVar The name of the array in which to put argument defaults. |
||||
# |
||||
# Results |
||||
# Name value pairs suitable for using with array set. |
||||
|
||||
proc ::cmdline::GetOptionDefaults {optlist defaultArrayVar} { |
||||
upvar 1 $defaultArrayVar result |
||||
|
||||
set opts {? help} |
||||
foreach opt $optlist { |
||||
set name [lindex $opt 0] |
||||
if {[regsub -- {\.secret$} $name {} name] == 1} { |
||||
# Need to hide this from the usage display and getopt |
||||
} |
||||
lappend opts $name |
||||
if {[regsub -- {\.arg$} $name {} name] == 1} { |
||||
|
||||
# Set defaults for those that take values. |
||||
|
||||
set default [lindex $opt 1] |
||||
set result($name) $default |
||||
} else { |
||||
# The default for booleans is false |
||||
set result($name) 0 |
||||
} |
||||
} |
||||
return $opts |
||||
} |
||||
|
||||
# ::cmdline::usage -- |
||||
# |
||||
# Generate an error message that lists the allowed flags. |
||||
# |
||||
# Arguments: |
||||
# optlist As for cmdline::getoptions |
||||
# usage Text to include in the usage display. Defaults to |
||||
# "options:" |
||||
# |
||||
# Results |
||||
# A formatted usage message |
||||
|
||||
proc ::cmdline::usage {optlist {usage {options:}}} { |
||||
set str "[getArgv0] $usage\n" |
||||
set longest 20 |
||||
set lines {} |
||||
foreach opt [concat $optlist \ |
||||
{{- "Forcibly stop option processing"} {help "Print this message"} {? "Print this message"}}] { |
||||
set name "-[lindex $opt 0]" |
||||
if {[regsub -- {\.secret$} $name {} name] == 1} { |
||||
# Hidden option |
||||
continue |
||||
} |
||||
if {[regsub -- {\.arg$} $name {} name] == 1} { |
||||
append name " value" |
||||
set desc "[lindex $opt 2] <[lindex $opt 1]>" |
||||
} else { |
||||
set desc "[lindex $opt 1]" |
||||
} |
||||
set n [string length $name] |
||||
if {$n > $longest} { set longest $n } |
||||
# max not available before 8.5 - set longest [expr {max($longest, )}] |
||||
lappend lines $name $desc |
||||
} |
||||
foreach {name desc} $lines { |
||||
append str "[string trimright [format " %-*s %s" $longest $name $desc]]\n" |
||||
} |
||||
|
||||
return $str |
||||
} |
||||
|
||||
# ::cmdline::getfiles -- |
||||
# |
||||
# Given a list of file arguments from the command line, compute |
||||
# the set of valid files. On windows, file globbing is performed |
||||
# on each argument. On Unix, only file existence is tested. If |
||||
# a file argument produces no valid files, a warning is optionally |
||||
# generated. |
||||
# |
||||
# This code also uses the full path for each file. If not |
||||
# given it prepends [pwd] to the filename. This ensures that |
||||
# these files will never conflict with files in our zip file. |
||||
# |
||||
# Arguments: |
||||
# patterns The file patterns specified by the user. |
||||
# quiet If this flag is set, no warnings will be generated. |
||||
# |
||||
# Results: |
||||
# Returns the list of files that match the input patterns. |
||||
|
||||
proc ::cmdline::getfiles {patterns quiet} { |
||||
set result {} |
||||
if {$::tcl_platform(platform) == "windows"} { |
||||
foreach pattern $patterns { |
||||
set pat [file join $pattern] |
||||
set files [glob -nocomplain -- $pat] |
||||
if {$files == {}} { |
||||
if {! $quiet} { |
||||
puts stdout "warning: no files match \"$pattern\"" |
||||
} |
||||
} else { |
||||
foreach file $files { |
||||
lappend result $file |
||||
} |
||||
} |
||||
} |
||||
} else { |
||||
set result $patterns |
||||
} |
||||
set files {} |
||||
foreach file $result { |
||||
# Make file an absolute path so that we will never conflict |
||||
# with files that might be contained in our zip file. |
||||
set fullPath [file join [pwd] $file] |
||||
|
||||
if {[file isfile $fullPath]} { |
||||
lappend files $fullPath |
||||
} elseif {! $quiet} { |
||||
puts stdout "warning: no files match \"$file\"" |
||||
} |
||||
} |
||||
return $files |
||||
} |
||||
|
||||
# ::cmdline::getArgv0 -- |
||||
# |
||||
# This command returns the "sanitized" version of argv0. It will strip |
||||
# off the leading path and remove the ".bin" extensions that our apps |
||||
# use because they must be wrapped by a shell script. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# The application name that can be used in error messages. |
||||
|
||||
proc ::cmdline::getArgv0 {} { |
||||
global argv0 |
||||
|
||||
set name [file tail $argv0] |
||||
return [file rootname $name] |
||||
} |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
# Now the typed versions of the above commands. |
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
# typedCmdline.tcl -- |
||||
# |
||||
# This package provides a utility for parsing typed command |
||||
# line arguments that may be processed by various applications. |
||||
# |
||||
# Copyright (c) 2000 by Ross Palmer Mohn. |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: cmdline.tcl,v 1.28 2011/02/23 17:41:52 andreas_kupries Exp $ |
||||
|
||||
namespace eval ::cmdline { |
||||
namespace export typedGetopt typedGetoptions typedUsage |
||||
|
||||
# variable cmdline::charclasses -- |
||||
# |
||||
# Create regexp list of allowable character classes |
||||
# from "string is" error message. |
||||
# |
||||
# Results: |
||||
# String of character class names separated by "|" characters. |
||||
|
||||
variable charclasses |
||||
#checker exclude badKey |
||||
catch {string is . .} charclasses |
||||
variable dummy |
||||
regexp -- {must be (.+)$} $charclasses dummy charclasses |
||||
regsub -all -- {, (or )?} $charclasses {|} charclasses |
||||
unset dummy |
||||
} |
||||
|
||||
# ::cmdline::typedGetopt -- |
||||
# |
||||
# The cmdline::typedGetopt works in a fashion like the standard |
||||
# C based getopt function. Given an option string and a |
||||
# pointer to a list of args this command will process the |
||||
# first argument and return info on how to proceed. In addition, |
||||
# you may specify a type for the argument to each option. |
||||
# |
||||
# Arguments: |
||||
# argvVar Name of the argv list that you want to process. |
||||
# If options are found, the arg list is modified |
||||
# and the processed arguments are removed from the |
||||
# start of the list. |
||||
# |
||||
# optstring A list of command options that the application |
||||
# will accept. If the option ends in ".xxx", where |
||||
# xxx is any valid character class to the tcl |
||||
# command "string is", then typedGetopt routine will |
||||
# use the next argument as a typed argument to the |
||||
# option. The argument must match the specified |
||||
# character classes (e.g. integer, double, boolean, |
||||
# xdigit, etc.). Alternatively, you may specify |
||||
# ".arg" for an untyped argument. |
||||
# |
||||
# optVar Upon success, the variable pointed to by optVar |
||||
# contains the option that was found (without the |
||||
# leading '-' and without the .xxx extension). If |
||||
# typedGetopt fails the variable is set to the empty |
||||
# string. SOMETIMES! Different for each -value! |
||||
# |
||||
# argVar Upon success, the variable pointed to by argVar |
||||
# contains the argument for the specified option. |
||||
# If typedGetopt fails, the variable is filled with |
||||
# an error message. |
||||
# |
||||
# Argument type syntax: |
||||
# Option that takes no argument. |
||||
# foo |
||||
# |
||||
# Option that takes a typeless argument. |
||||
# foo.arg |
||||
# |
||||
# Option that takes a typed argument. Allowable types are all |
||||
# valid character classes to the tcl command "string is". |
||||
# Currently must be one of alnum, alpha, ascii, control, |
||||
# boolean, digit, double, false, graph, integer, lower, print, |
||||
# punct, space, true, upper, wordchar, or xdigit. |
||||
# foo.double |
||||
# |
||||
# Option that takes an argument from a list. |
||||
# foo.(bar|blat) |
||||
# |
||||
# Argument quantifier syntax: |
||||
# Option that takes an optional argument. |
||||
# foo.arg? |
||||
# |
||||
# Option that takes a list of arguments terminated by "--". |
||||
# foo.arg+ |
||||
# |
||||
# Option that takes an optional list of arguments terminated by "--". |
||||
# foo.arg* |
||||
# |
||||
# Argument quantifiers work on all argument types, so, for |
||||
# example, the following is a valid option specification. |
||||
# foo.(bar|blat|blah)? |
||||
# |
||||
# Argument syntax miscellany: |
||||
# Options may be specified on the command line using a unique, |
||||
# shortened version of the option name. Given that program foo |
||||
# has an option list of {bar.alpha blah.arg blat.double}, |
||||
# "foo -b fob" returns an error, but "foo -ba fob" |
||||
# successfully returns {bar fob} |
||||
# |
||||
# Results: |
||||
# The typedGetopt function returns one of the following: |
||||
# 1 a valid option was found |
||||
# 0 no more options found to process |
||||
# -1 invalid option |
||||
# -2 missing argument to a valid option |
||||
# -3 argument to a valid option does not match type |
||||
# |
||||
# Known Bugs: |
||||
# When using options which include special glob characters, |
||||
# you must use the exact option. Abbreviating it can cause |
||||
# an error in the "cmdline::prefixSearch" procedure. |
||||
|
||||
proc ::cmdline::typedGetopt {argvVar optstring optVar argVar} { |
||||
variable charclasses |
||||
|
||||
upvar $argvVar argsList |
||||
|
||||
upvar $optVar retvar |
||||
upvar $argVar optarg |
||||
|
||||
# default settings for a normal return |
||||
set optarg "" |
||||
set retvar "" |
||||
set retval 0 |
||||
|
||||
# check if we're past the end of the args list |
||||
if {[llength $argsList] != 0} { |
||||
|
||||
# if we got -- or an option that doesn't begin with -, return (skipping |
||||
# the --). otherwise process the option arg. |
||||
switch -glob -- [set arg [lindex $argsList 0]] { |
||||
"--" { |
||||
set argsList [lrange $argsList 1 end] |
||||
} |
||||
|
||||
"-*" { |
||||
# Create list of options without their argument extensions |
||||
|
||||
set optstr "" |
||||
foreach str $optstring { |
||||
lappend optstr [file rootname $str] |
||||
} |
||||
|
||||
set _opt [string range $arg 1 end] |
||||
|
||||
set i [prefixSearch $optstr [file rootname $_opt]] |
||||
if {$i != -1} { |
||||
set opt [lindex $optstring $i] |
||||
|
||||
set quantifier "none" |
||||
if {[regexp -- {\.[^.]+([?+*])$} $opt dummy quantifier]} { |
||||
set opt [string range $opt 0 end-1] |
||||
} |
||||
|
||||
if {[string first . $opt] == -1} { |
||||
set retval 1 |
||||
set retvar $opt |
||||
set argsList [lrange $argsList 1 end] |
||||
|
||||
} elseif {[regexp -- "\\.(arg|$charclasses)\$" $opt dummy charclass] |
||||
|| [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]} { |
||||
if {[string equal arg $charclass]} { |
||||
set type arg |
||||
} elseif {[regexp -- "^($charclasses)\$" $charclass]} { |
||||
set type class |
||||
} else { |
||||
set type oneof |
||||
} |
||||
|
||||
set argsList [lrange $argsList 1 end] |
||||
set opt [file rootname $opt] |
||||
|
||||
while {1} { |
||||
if {[llength $argsList] == 0 |
||||
|| [string equal "--" [lindex $argsList 0]]} { |
||||
if {[string equal "--" [lindex $argsList 0]]} { |
||||
set argsList [lrange $argsList 1 end] |
||||
} |
||||
|
||||
set oneof "" |
||||
if {$type == "arg"} { |
||||
set charclass an |
||||
} elseif {$type == "oneof"} { |
||||
set oneof ", one of $charclass" |
||||
set charclass an |
||||
} |
||||
|
||||
if {$quantifier == "?"} { |
||||
set retval 1 |
||||
set retvar $opt |
||||
set optarg "" |
||||
} elseif {$quantifier == "+"} { |
||||
set retvar $opt |
||||
if {[llength $optarg] < 1} { |
||||
set retval -2 |
||||
set optarg "Option requires at least one $charclass argument$oneof -- $opt" |
||||
} else { |
||||
set retval 1 |
||||
} |
||||
} elseif {$quantifier == "*"} { |
||||
set retval 1 |
||||
set retvar $opt |
||||
} else { |
||||
set optarg "Option requires $charclass argument$oneof -- $opt" |
||||
set retvar $opt |
||||
set retval -2 |
||||
} |
||||
set quantifier "" |
||||
} elseif {($type == "arg") |
||||
|| (($type == "oneof") |
||||
&& [string first "|[lindex $argsList 0]|" "|$charclass|"] != -1) |
||||
|| (($type == "class") |
||||
&& [string is $charclass [lindex $argsList 0]])} { |
||||
set retval 1 |
||||
set retvar $opt |
||||
lappend optarg [lindex $argsList 0] |
||||
set argsList [lrange $argsList 1 end] |
||||
} else { |
||||
set oneof "" |
||||
if {$type == "arg"} { |
||||
set charclass an |
||||
} elseif {$type == "oneof"} { |
||||
set oneof ", one of $charclass" |
||||
set charclass an |
||||
} |
||||
set optarg "Option requires $charclass argument$oneof -- $opt" |
||||
set retvar $opt |
||||
set retval -3 |
||||
|
||||
if {$quantifier == "?"} { |
||||
set retval 1 |
||||
set optarg "" |
||||
} |
||||
set quantifier "" |
||||
} |
||||
if {![regexp -- {[+*]} $quantifier]} { |
||||
break; |
||||
} |
||||
} |
||||
} else { |
||||
Error \ |
||||
"Illegal option type specification: must be one of $charclasses" \ |
||||
BAD OPTION TYPE |
||||
} |
||||
} else { |
||||
set optarg "Illegal option -- $_opt" |
||||
set retvar $_opt |
||||
set retval -1 |
||||
} |
||||
} |
||||
default { |
||||
# Skip ahead |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $retval |
||||
} |
||||
|
||||
# ::cmdline::typedGetoptions -- |
||||
# |
||||
# Process a set of command line options, filling in defaults |
||||
# for those not specified. This also generates an error message |
||||
# that lists the allowed options if an incorrect option is |
||||
# specified. |
||||
# |
||||
# Arguments: |
||||
# argvVar The name of the argument list, typically argv |
||||
# optlist A list-of-lists where each element specifies an option |
||||
# in the form: |
||||
# |
||||
# option default comment |
||||
# |
||||
# Options formatting is as described for the optstring |
||||
# argument of typedGetopt. Default is for optionally |
||||
# specifying a default value. Comment is for optionally |
||||
# specifying a comment for the usage display. The |
||||
# options "--", "-help", and "-?" are automatically included |
||||
# in optlist. |
||||
# |
||||
# Argument syntax miscellany: |
||||
# Options formatting and syntax is as described in typedGetopt. |
||||
# There are two additional suffixes that may be applied when |
||||
# passing options to typedGetoptions. |
||||
# |
||||
# You may add ".multi" as a suffix to any option. For options |
||||
# that take an argument, this means that the option may be used |
||||
# more than once on the command line and that each additional |
||||
# argument will be appended to a list, which is then returned |
||||
# to the application. |
||||
# foo.double.multi |
||||
# |
||||
# If a non-argument option is specified as ".multi", it is |
||||
# toggled on and off for each time it is used on the command |
||||
# line. |
||||
# foo.multi |
||||
# |
||||
# If an option specification does not contain the ".multi" |
||||
# suffix, it is not an error to use an option more than once. |
||||
# In this case, the behavior for options with arguments is that |
||||
# the last argument is the one that will be returned. For |
||||
# options that do not take arguments, using them more than once |
||||
# has no additional effect. |
||||
# |
||||
# Options may also be hidden from the usage display by |
||||
# appending the suffix ".secret" to any option specification. |
||||
# Please note that the ".secret" suffix must be the last suffix, |
||||
# after any argument type specification and ".multi" suffix. |
||||
# foo.xdigit.multi.secret |
||||
# |
||||
# Results |
||||
# Name value pairs suitable for using with array set. |
||||
|
||||
proc ::cmdline::typedGetoptions {argvVar optlist {usage options:}} { |
||||
variable charclasses |
||||
|
||||
upvar 1 $argvVar argv |
||||
|
||||
set opts {? help} |
||||
foreach opt $optlist { |
||||
set name [lindex $opt 0] |
||||
if {[regsub -- {\.secret$} $name {} name] == 1} { |
||||
# Remove this extension before passing to typedGetopt. |
||||
} |
||||
if {[regsub -- {\.multi$} $name {} name] == 1} { |
||||
# Remove this extension before passing to typedGetopt. |
||||
|
||||
regsub -- {\..*$} $name {} temp |
||||
set multi($temp) 1 |
||||
} |
||||
lappend opts $name |
||||
if {[regsub -- "\\.(arg|$charclasses|\\(.+).?\$" $name {} name] == 1} { |
||||
# Set defaults for those that take values. |
||||
# Booleans are set just by being present, or not |
||||
|
||||
set dflt [lindex $opt 1] |
||||
if {$dflt != {}} { |
||||
set defaults($name) $dflt |
||||
} |
||||
} |
||||
} |
||||
set argc [llength $argv] |
||||
while {[set err [typedGetopt argv $opts opt arg]]} { |
||||
if {$err == 1} { |
||||
if {[info exists result($opt)] |
||||
&& [info exists multi($opt)]} { |
||||
# Toggle boolean options or append new arguments |
||||
|
||||
if {$arg == ""} { |
||||
unset result($opt) |
||||
} else { |
||||
set result($opt) "$result($opt) $arg" |
||||
} |
||||
} else { |
||||
set result($opt) "$arg" |
||||
} |
||||
} elseif {($err == -1) || ($err == -3)} { |
||||
Error [typedUsage $optlist $usage] USAGE |
||||
} elseif {$err == -2 && ![info exists defaults($opt)]} { |
||||
Error [typedUsage $optlist $usage] USAGE |
||||
} |
||||
} |
||||
if {[info exists result(?)] || [info exists result(help)]} { |
||||
Error [typedUsage $optlist $usage] USAGE |
||||
} |
||||
foreach {opt dflt} [array get defaults] { |
||||
if {![info exists result($opt)]} { |
||||
set result($opt) $dflt |
||||
} |
||||
} |
||||
return [array get result] |
||||
} |
||||
|
||||
# ::cmdline::typedUsage -- |
||||
# |
||||
# Generate an error message that lists the allowed flags, |
||||
# type of argument taken (if any), default value (if any), |
||||
# and an optional description. |
||||
# |
||||
# Arguments: |
||||
# optlist As for cmdline::typedGetoptions |
||||
# |
||||
# Results |
||||
# A formatted usage message |
||||
|
||||
proc ::cmdline::typedUsage {optlist {usage {options:}}} { |
||||
variable charclasses |
||||
|
||||
set str "[getArgv0] $usage\n" |
||||
set longest 20 |
||||
set lines {} |
||||
foreach opt [concat $optlist \ |
||||
{{help "Print this message"} {? "Print this message"}}] { |
||||
set name "-[lindex $opt 0]" |
||||
if {[regsub -- {\.secret$} $name {} name] == 1} { |
||||
# Hidden option |
||||
continue |
||||
} |
||||
|
||||
if {[regsub -- {\.multi$} $name {} name] == 1} { |
||||
# Display something about multiple options |
||||
} |
||||
|
||||
if {[regexp -- "\\.(arg|$charclasses)\$" $name dummy charclass] || |
||||
[regexp -- {\.\(([^)]+)\)} $opt dummy charclass] |
||||
} { |
||||
regsub -- "\\..+\$" $name {} name |
||||
append name " $charclass" |
||||
set desc [lindex $opt 2] |
||||
set default [lindex $opt 1] |
||||
if {$default != ""} { |
||||
append desc " <$default>" |
||||
} |
||||
} else { |
||||
set desc [lindex $opt 1] |
||||
} |
||||
lappend accum $name $desc |
||||
set n [string length $name] |
||||
if {$n > $longest} { set longest $n } |
||||
# max not available before 8.5 - set longest [expr {max($longest, [string length $name])}] |
||||
} |
||||
foreach {name desc} $accum { |
||||
append str "[string trimright [format " %-*s %s" $longest $name $desc]]\n" |
||||
} |
||||
return $str |
||||
} |
||||
|
||||
# ::cmdline::prefixSearch -- |
||||
# |
||||
# Search a Tcl list for a pattern; searches first for an exact match, |
||||
# and if that fails, for a unique prefix that matches the pattern |
||||
# (i.e, first "lsearch -exact", then "lsearch -glob $pattern*" |
||||
# |
||||
# Arguments: |
||||
# list list of words |
||||
# pattern word to search for |
||||
# |
||||
# Results: |
||||
# Index of found word is returned. If no exact match or |
||||
# unique short version is found then -1 is returned. |
||||
|
||||
proc ::cmdline::prefixSearch {list pattern} { |
||||
# Check for an exact match |
||||
|
||||
if {[set pos [::lsearch -exact $list $pattern]] > -1} { |
||||
return $pos |
||||
} |
||||
|
||||
# Check for a unique short version |
||||
|
||||
set slist [lsort $list] |
||||
if {[set pos [::lsearch -glob $slist $pattern*]] > -1} { |
||||
# What if there is nothing for the check variable? |
||||
|
||||
set check [lindex $slist [expr {$pos + 1}]] |
||||
if {[string first $pattern $check] != 0} { |
||||
return [::lsearch -exact $list [lindex $slist $pos]] |
||||
} |
||||
} |
||||
return -1 |
||||
} |
||||
# ::cmdline::Error -- |
||||
# |
||||
# Internal helper to throw errors with a proper error-code attached. |
||||
# |
||||
# Arguments: |
||||
# message text of the error message to throw. |
||||
# args additional parts of the error code to use, |
||||
# with CMDLINE as basic prefix added by this command. |
||||
# |
||||
# Results: |
||||
# An error is thrown, always. |
||||
|
||||
proc ::cmdline::Error {message args} { |
||||
return -code error -errorcode [linsert $args 0 CMDLINE] $message |
||||
} |
||||
@ -0,0 +1,189 @@
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# sets.tcl -- |
||||
# |
||||
# Definitions for the processing of sets. |
||||
# |
||||
# Copyright (c) 2004-2008 by Andreas Kupries. |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: sets.tcl,v 1.17 2008/03/09 04:24:37 andreas_kupries Exp $ |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
# @mdgen EXCLUDE: sets_c.tcl |
||||
|
||||
package require Tcl 8.5- |
||||
|
||||
namespace eval ::struct::set {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Management of set implementations. |
||||
|
||||
# ::struct::set::LoadAccelerator -- |
||||
# |
||||
# Loads a named implementation, if possible. |
||||
# |
||||
# Arguments: |
||||
# key Name of the implementation to load. |
||||
# |
||||
# Results: |
||||
# A boolean flag. True if the implementation |
||||
# was successfully loaded; and False otherwise. |
||||
|
||||
proc ::struct::set::LoadAccelerator {key} { |
||||
variable accel |
||||
set r 0 |
||||
switch -exact -- $key { |
||||
critcl { |
||||
# Critcl implementation of set requires Tcl 8.4. |
||||
if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} |
||||
if {[catch {package require tcllibc}]} {return 0} |
||||
set r [llength [info commands ::struct::set_critcl]] |
||||
} |
||||
tcl { |
||||
variable selfdir |
||||
source [file join $selfdir sets_tcl.tcl] |
||||
set r 1 |
||||
} |
||||
default { |
||||
return -code error "invalid accelerator/impl. package $key:\ |
||||
must be one of [join [KnownImplementations] {, }]" |
||||
} |
||||
} |
||||
set accel($key) $r |
||||
return $r |
||||
} |
||||
|
||||
# ::struct::set::SwitchTo -- |
||||
# |
||||
# Activates a loaded named implementation. |
||||
# |
||||
# Arguments: |
||||
# key Name of the implementation to activate. |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
proc ::struct::set::SwitchTo {key} { |
||||
variable accel |
||||
variable loaded |
||||
|
||||
if {[string equal $key $loaded]} { |
||||
# No change, nothing to do. |
||||
return |
||||
} elseif {![string equal $key ""]} { |
||||
# Validate the target implementation of the switch. |
||||
|
||||
if {![info exists accel($key)]} { |
||||
return -code error "Unable to activate unknown implementation \"$key\"" |
||||
} elseif {![info exists accel($key)] || !$accel($key)} { |
||||
return -code error "Unable to activate missing implementation \"$key\"" |
||||
} |
||||
} |
||||
|
||||
# Deactivate the previous implementation, if there was any. |
||||
|
||||
if {![string equal $loaded ""]} { |
||||
rename ::struct::set ::struct::set_$loaded |
||||
} |
||||
|
||||
# Activate the new implementation, if there is any. |
||||
|
||||
if {![string equal $key ""]} { |
||||
rename ::struct::set_$key ::struct::set |
||||
} |
||||
|
||||
# Remember the active implementation, for deactivation by future |
||||
# switches. |
||||
|
||||
set loaded $key |
||||
return |
||||
} |
||||
|
||||
proc ::struct::set::Loaded {} { |
||||
variable loaded |
||||
return $loaded |
||||
} |
||||
|
||||
# ::struct::set::Implementations -- |
||||
# |
||||
# Determines which implementations are |
||||
# present, i.e. loaded. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# A list of implementation keys. |
||||
|
||||
proc ::struct::set::Implementations {} { |
||||
variable accel |
||||
set res {} |
||||
foreach n [array names accel] { |
||||
if {!$accel($n)} continue |
||||
lappend res $n |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
# ::struct::set::KnownImplementations -- |
||||
# |
||||
# Determines which implementations are known |
||||
# as possible implementations. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# A list of implementation keys. In the order |
||||
# of preference, most prefered first. |
||||
|
||||
proc ::struct::set::KnownImplementations {} { |
||||
return {critcl tcl} |
||||
} |
||||
|
||||
proc ::struct::set::Names {} { |
||||
return { |
||||
critcl {tcllibc based} |
||||
tcl {pure Tcl} |
||||
} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Initialization: Data structures. |
||||
|
||||
namespace eval ::struct::set { |
||||
variable selfdir [file dirname [info script]] |
||||
variable accel |
||||
array set accel {tcl 0 critcl 0} |
||||
variable loaded {} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Initialization: Choose an implementation, |
||||
## most prefered first. Loads only one of the |
||||
## possible implementations. And activates it. |
||||
|
||||
namespace eval ::struct::set { |
||||
variable e |
||||
foreach e [KnownImplementations] { |
||||
if {[LoadAccelerator $e]} { |
||||
SwitchTo $e |
||||
break |
||||
} |
||||
} |
||||
unset e |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
namespace eval ::struct { |
||||
# Export the constructor command. |
||||
namespace export set |
||||
} |
||||
|
||||
package provide struct::set 2.2.3 |
||||
@ -0,0 +1,189 @@
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# sets.tcl -- |
||||
# |
||||
# Definitions for the processing of sets. |
||||
# |
||||
# Copyright (c) 2004-2008 by Andreas Kupries. |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: sets.tcl,v 1.17 2008/03/09 04:24:37 andreas_kupries Exp $ |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
# @mdgen EXCLUDE: sets_c.tcl |
||||
|
||||
package require Tcl 8.5- |
||||
|
||||
namespace eval ::struct::set {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Management of set implementations. |
||||
|
||||
# ::struct::set::LoadAccelerator -- |
||||
# |
||||
# Loads a named implementation, if possible. |
||||
# |
||||
# Arguments: |
||||
# key Name of the implementation to load. |
||||
# |
||||
# Results: |
||||
# A boolean flag. True if the implementation |
||||
# was successfully loaded; and False otherwise. |
||||
|
||||
proc ::struct::set::LoadAccelerator {key} { |
||||
variable accel |
||||
set r 0 |
||||
switch -exact -- $key { |
||||
critcl { |
||||
# Critcl implementation of set requires Tcl 8.4. |
||||
if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} |
||||
if {[catch {package require tcllibc}]} {return 0} |
||||
set r [llength [info commands ::struct::set_critcl]] |
||||
} |
||||
tcl { |
||||
variable selfdir |
||||
source [file join $selfdir sets_tcl.tcl] |
||||
set r 1 |
||||
} |
||||
default { |
||||
return -code error "invalid accelerator/impl. package $key:\ |
||||
must be one of [join [KnownImplementations] {, }]" |
||||
} |
||||
} |
||||
set accel($key) $r |
||||
return $r |
||||
} |
||||
|
||||
# ::struct::set::SwitchTo -- |
||||
# |
||||
# Activates a loaded named implementation. |
||||
# |
||||
# Arguments: |
||||
# key Name of the implementation to activate. |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
proc ::struct::set::SwitchTo {key} { |
||||
variable accel |
||||
variable loaded |
||||
|
||||
if {[string equal $key $loaded]} { |
||||
# No change, nothing to do. |
||||
return |
||||
} elseif {![string equal $key ""]} { |
||||
# Validate the target implementation of the switch. |
||||
|
||||
if {![info exists accel($key)]} { |
||||
return -code error "Unable to activate unknown implementation \"$key\"" |
||||
} elseif {![info exists accel($key)] || !$accel($key)} { |
||||
return -code error "Unable to activate missing implementation \"$key\"" |
||||
} |
||||
} |
||||
|
||||
# Deactivate the previous implementation, if there was any. |
||||
|
||||
if {![string equal $loaded ""]} { |
||||
rename ::struct::set ::struct::set_$loaded |
||||
} |
||||
|
||||
# Activate the new implementation, if there is any. |
||||
|
||||
if {![string equal $key ""]} { |
||||
rename ::struct::set_$key ::struct::set |
||||
} |
||||
|
||||
# Remember the active implementation, for deactivation by future |
||||
# switches. |
||||
|
||||
set loaded $key |
||||
return |
||||
} |
||||
|
||||
proc ::struct::set::Loaded {} { |
||||
variable loaded |
||||
return $loaded |
||||
} |
||||
|
||||
# ::struct::set::Implementations -- |
||||
# |
||||
# Determines which implementations are |
||||
# present, i.e. loaded. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# A list of implementation keys. |
||||
|
||||
proc ::struct::set::Implementations {} { |
||||
variable accel |
||||
set res {} |
||||
foreach n [array names accel] { |
||||
if {!$accel($n)} continue |
||||
lappend res $n |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
# ::struct::set::KnownImplementations -- |
||||
# |
||||
# Determines which implementations are known |
||||
# as possible implementations. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# A list of implementation keys. In the order |
||||
# of preference, most prefered first. |
||||
|
||||
proc ::struct::set::KnownImplementations {} { |
||||
return {critcl tcl} |
||||
} |
||||
|
||||
proc ::struct::set::Names {} { |
||||
return { |
||||
critcl {tcllibc based} |
||||
tcl {pure Tcl} |
||||
} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Initialization: Data structures. |
||||
|
||||
namespace eval ::struct::set { |
||||
variable selfdir [file dirname [info script]] |
||||
variable accel |
||||
array set accel {tcl 0 critcl 0} |
||||
variable loaded {} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Initialization: Choose an implementation, |
||||
## most prefered first. Loads only one of the |
||||
## possible implementations. And activates it. |
||||
|
||||
namespace eval ::struct::set { |
||||
variable e |
||||
foreach e [KnownImplementations] { |
||||
if {[LoadAccelerator $e]} { |
||||
SwitchTo $e |
||||
break |
||||
} |
||||
} |
||||
unset e |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
namespace eval ::struct { |
||||
# Export the constructor command. |
||||
namespace export set |
||||
} |
||||
|
||||
package provide struct::set 2.2.3 |
||||
@ -0,0 +1,93 @@
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# sets_tcl.tcl -- |
||||
# |
||||
# Definitions for the processing of sets. C implementation. |
||||
# |
||||
# Copyright (c) 2007 by Andreas Kupries. |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: sets_c.tcl,v 1.3 2008/03/25 07:15:34 andreas_kupries Exp $ |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
package require critcl |
||||
# @sak notprovided struct_setc |
||||
package provide struct_setc 2.1.1 |
||||
package require Tcl 8.5- |
||||
|
||||
namespace eval ::struct { |
||||
# Supporting code for the main command. |
||||
|
||||
catch { |
||||
#critcl::cheaders -g |
||||
#critcl::debug memory symbols |
||||
} |
||||
|
||||
critcl::cheaders sets/*.h |
||||
critcl::csources sets/*.c |
||||
|
||||
critcl::ccode { |
||||
/* -*- c -*- */ |
||||
|
||||
#include <m.h> |
||||
} |
||||
|
||||
# Main command, set creation. |
||||
|
||||
critcl::ccommand set_critcl {dummy interp objc objv} { |
||||
/* Syntax - dispatcher to the sub commands. |
||||
*/ |
||||
|
||||
static CONST char* methods [] = { |
||||
"add", "contains", "difference", "empty", |
||||
"equal","exclude", "include", "intersect", |
||||
"intersect3", "size", "subsetof", "subtract", |
||||
"symdiff", "union", |
||||
NULL |
||||
}; |
||||
enum methods { |
||||
S_add, S_contains, S_difference, S_empty, |
||||
S_equal,S_exclude, S_include, S_intersect, |
||||
S_intersect3, S_size, S_subsetof, S_subtract, |
||||
S_symdiff, S_union |
||||
}; |
||||
|
||||
int m; |
||||
|
||||
if (objc < 2) { |
||||
Tcl_WrongNumArgs (interp, objc, objv, "cmd ?arg ...?"); |
||||
return TCL_ERROR; |
||||
} else if (Tcl_GetIndexFromObj (interp, objv [1], methods, "option", |
||||
0, &m) != TCL_OK) { |
||||
return TCL_ERROR; |
||||
} |
||||
|
||||
/* Dispatch to methods. They check the #args in detail before performing |
||||
* the requested functionality |
||||
*/ |
||||
|
||||
switch (m) { |
||||
case S_add: return sm_ADD (NULL, interp, objc, objv); |
||||
case S_contains: return sm_CONTAINS (NULL, interp, objc, objv); |
||||
case S_difference: return sm_DIFFERENCE (NULL, interp, objc, objv); |
||||
case S_empty: return sm_EMPTY (NULL, interp, objc, objv); |
||||
case S_equal: return sm_EQUAL (NULL, interp, objc, objv); |
||||
case S_exclude: return sm_EXCLUDE (NULL, interp, objc, objv); |
||||
case S_include: return sm_INCLUDE (NULL, interp, objc, objv); |
||||
case S_intersect: return sm_INTERSECT (NULL, interp, objc, objv); |
||||
case S_intersect3: return sm_INTERSECT3 (NULL, interp, objc, objv); |
||||
case S_size: return sm_SIZE (NULL, interp, objc, objv); |
||||
case S_subsetof: return sm_SUBSETOF (NULL, interp, objc, objv); |
||||
case S_subtract: return sm_SUBTRACT (NULL, interp, objc, objv); |
||||
case S_symdiff: return sm_SYMDIFF (NULL, interp, objc, objv); |
||||
case S_union: return sm_UNION (NULL, interp, objc, objv); |
||||
} |
||||
/* Not coming to this place */ |
||||
} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
@ -0,0 +1,452 @@
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# sets_tcl.tcl -- |
||||
# |
||||
# Definitions for the processing of sets. |
||||
# |
||||
# Copyright (c) 2004-2008 by Andreas Kupries. |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: sets_tcl.tcl,v 1.4 2008/03/09 04:38:47 andreas_kupries Exp $ |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
package require Tcl 8.5- |
||||
|
||||
namespace eval ::struct::set { |
||||
# Only export one command, the one used to instantiate a new tree |
||||
namespace export set_tcl |
||||
} |
||||
|
||||
########################## |
||||
# Public functions |
||||
|
||||
# ::struct::set::set -- |
||||
# |
||||
# Command that access all set commands. |
||||
# |
||||
# Arguments: |
||||
# cmd Name of the subcommand to dispatch to. |
||||
# args Arguments for the subcommand. |
||||
# |
||||
# Results: |
||||
# Whatever the result of the subcommand is. |
||||
|
||||
proc ::struct::set::set_tcl {cmd args} { |
||||
# Do minimal args checks here |
||||
if { [llength [info level 0]] == 1 } { |
||||
return -code error "wrong # args: should be \"$cmd ?arg arg ...?\"" |
||||
} |
||||
::set sub S_$cmd |
||||
if { [llength [info commands ::struct::set::$sub]] == 0 } { |
||||
::set optlist [info commands ::struct::set::S_*] |
||||
::set xlist {} |
||||
foreach p $optlist { |
||||
lappend xlist [string range $p 17 end] |
||||
} |
||||
return -code error \ |
||||
"bad option \"$cmd\": must be [linsert [join [lsort $xlist] ", "] "end-1" "or"]" |
||||
} |
||||
return [uplevel 1 [linsert $args 0 ::struct::set::$sub]] |
||||
} |
||||
|
||||
########################## |
||||
# Implementations of the functionality. |
||||
# |
||||
|
||||
# ::struct::set::S_empty -- |
||||
# |
||||
# Determines emptiness of the set |
||||
# |
||||
# Parameters: |
||||
# set -- The set to check for emptiness. |
||||
# |
||||
# Results: |
||||
# A boolean value. True indicates that the set is empty. |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
# |
||||
# Notes: |
||||
|
||||
proc ::struct::set::S_empty {set} { |
||||
return [expr {[llength $set] == 0}] |
||||
} |
||||
|
||||
# ::struct::set::S_size -- |
||||
# |
||||
# Computes the cardinality of the set. |
||||
# |
||||
# Parameters: |
||||
# set -- The set to inspect. |
||||
# |
||||
# Results: |
||||
# An integer greater than or equal to zero. |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_size {set} { |
||||
return [llength [Cleanup $set]] |
||||
} |
||||
|
||||
# ::struct::set::S_contains -- |
||||
# |
||||
# Determines if the item is in the set. |
||||
# |
||||
# Parameters: |
||||
# set -- The set to inspect. |
||||
# item -- The element to look for. |
||||
# |
||||
# Results: |
||||
# A boolean value. True indicates that the element is present. |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_contains {set item} { |
||||
return [expr {[lsearch -exact $set $item] >= 0}] |
||||
} |
||||
|
||||
# ::struct::set::S_union -- |
||||
# |
||||
# Computes the union of the arguments. |
||||
# |
||||
# Parameters: |
||||
# args -- List of sets to unify. |
||||
# |
||||
# Results: |
||||
# The union of the arguments. |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_union {args} { |
||||
switch -exact -- [llength $args] { |
||||
0 {return {}} |
||||
1 {return [lindex $args 0]} |
||||
} |
||||
foreach setX $args { |
||||
foreach x $setX {::set ($x) {}} |
||||
} |
||||
return [array names {}] |
||||
} |
||||
|
||||
|
||||
# ::struct::set::S_intersect -- |
||||
# |
||||
# Computes the intersection of the arguments. |
||||
# |
||||
# Parameters: |
||||
# args -- List of sets to intersect. |
||||
# |
||||
# Results: |
||||
# The intersection of the arguments |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_intersect {args} { |
||||
switch -exact -- [llength $args] { |
||||
0 {return {}} |
||||
1 {return [lindex $args 0]} |
||||
} |
||||
::set res [lindex $args 0] |
||||
foreach set [lrange $args 1 end] { |
||||
if {[llength $res] && [llength $set]} { |
||||
::set res [Intersect $res $set] |
||||
} else { |
||||
# Squash 'res'. Otherwise we get the wrong result if res |
||||
# is not empty, but 'set' is. |
||||
::set res {} |
||||
break |
||||
} |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
proc ::struct::set::Intersect {A B} { |
||||
if {[llength $A] == 0} {return {}} |
||||
if {[llength $B] == 0} {return {}} |
||||
|
||||
# This is slower than local vars, but more robust |
||||
if {[llength $B] > [llength $A]} { |
||||
::set res $A |
||||
::set A $B |
||||
::set B $res |
||||
} |
||||
::set res {} |
||||
foreach x $A {::set ($x) {}} |
||||
foreach x $B { |
||||
if {[info exists ($x)]} { |
||||
lappend res $x |
||||
} |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
# ::struct::set::S_difference -- |
||||
# |
||||
# Compute difference of two sets. |
||||
# |
||||
# Parameters: |
||||
# A, B -- Sets to compute the difference for. |
||||
# |
||||
# Results: |
||||
# A - B |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_difference {A B} { |
||||
if {[llength $A] == 0} {return {}} |
||||
if {[llength $B] == 0} {return $A} |
||||
|
||||
array set tmp {} |
||||
foreach x $A {::set tmp($x) .} |
||||
foreach x $B {catch {unset tmp($x)}} |
||||
return [array names tmp] |
||||
} |
||||
|
||||
if {0} { |
||||
# Tcllib SF Bug 1002143. We cannot use the implementation below. |
||||
# It will treat set elements containing '(' and ')' as array |
||||
# elements, and this screws up the storage of elements as the name |
||||
# of local vars something fierce. No way around this. Disabling |
||||
# this code and always using the other implementation (s.a.) is |
||||
# the only possible fix. |
||||
|
||||
if {[package vcompare [package provide Tcl] 8.4] < 0} { |
||||
# Tcl 8.[23]. Use explicit array to perform the operation. |
||||
} else { |
||||
# Tcl 8.4+, has 'unset -nocomplain' |
||||
|
||||
proc ::struct::set::S_difference {A B} { |
||||
if {[llength $A] == 0} {return {}} |
||||
if {[llength $B] == 0} {return $A} |
||||
|
||||
# Get the variable B out of the way, avoid collisions |
||||
# prepare for "pure list optimization" |
||||
::set ::struct::set::tmp [lreplace $B -1 -1 unset -nocomplain] |
||||
unset B |
||||
|
||||
# unset A early: no local variables left |
||||
foreach [lindex [list $A [unset A]] 0] {.} {break} |
||||
|
||||
eval $::struct::set::tmp |
||||
return [info locals] |
||||
} |
||||
} |
||||
} |
||||
|
||||
# ::struct::set::S_symdiff -- |
||||
# |
||||
# Compute symmetric difference of two sets. |
||||
# |
||||
# Parameters: |
||||
# A, B -- The sets to compute the s.difference for. |
||||
# |
||||
# Results: |
||||
# The symmetric difference of the two input sets. |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_symdiff {A B} { |
||||
# symdiff == (A-B) + (B-A) == (A+B)-(A*B) |
||||
if {[llength $A] == 0} {return $B} |
||||
if {[llength $B] == 0} {return $A} |
||||
return [S_union \ |
||||
[S_difference $A $B] \ |
||||
[S_difference $B $A]] |
||||
} |
||||
|
||||
# ::struct::set::S_intersect3 -- |
||||
# |
||||
# Return intersection and differences for two sets. |
||||
# |
||||
# Parameters: |
||||
# A, B -- The sets to inspect. |
||||
# |
||||
# Results: |
||||
# List containing A*B, A-B, and B-A |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_intersect3 {A B} { |
||||
return [list \ |
||||
[S_intersect $A $B] \ |
||||
[S_difference $A $B] \ |
||||
[S_difference $B $A]] |
||||
} |
||||
|
||||
# ::struct::set::S_equal -- |
||||
# |
||||
# Compares two sets for equality. |
||||
# |
||||
# Parameters: |
||||
# a First set to compare. |
||||
# b Second set to compare. |
||||
# |
||||
# Results: |
||||
# A boolean. True if the lists are equal. |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_equal {A B} { |
||||
::set A [Cleanup $A] |
||||
::set B [Cleanup $B] |
||||
|
||||
# Equal if of same cardinality and difference is empty. |
||||
|
||||
if {[::llength $A] != [::llength $B]} {return 0} |
||||
return [expr {[llength [S_difference $A $B]] == 0}] |
||||
} |
||||
|
||||
|
||||
proc ::struct::set::Cleanup {A} { |
||||
# unset A to avoid collisions |
||||
if {[llength $A] < 2} {return $A} |
||||
# We cannot use variables to avoid an explicit array. The set |
||||
# elements may look like namespace vars (i.e. contain ::), and |
||||
# such elements break that, cannot be proc-local variables. |
||||
array set S {} |
||||
foreach item $A {set S($item) .} |
||||
return [array names S] |
||||
} |
||||
|
||||
# ::struct::set::S_include -- |
||||
# |
||||
# Add an element to a set. |
||||
# |
||||
# Parameters: |
||||
# Avar -- Reference to the set variable to extend. |
||||
# element -- The item to add to the set. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# The set in the variable referenced by Avar is extended |
||||
# by the element (if the element was not already present). |
||||
|
||||
proc ::struct::set::S_include {Avar element} { |
||||
# Avar = Avar + {element} |
||||
upvar 1 $Avar A |
||||
if {![info exists A] || ![S_contains $A $element]} { |
||||
lappend A $element |
||||
} |
||||
return |
||||
} |
||||
|
||||
# ::struct::set::S_exclude -- |
||||
# |
||||
# Remove an element from a set. |
||||
# |
||||
# Parameters: |
||||
# Avar -- Reference to the set variable to shrink. |
||||
# element -- The item to remove from the set. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# The set in the variable referenced by Avar is shrunk, |
||||
# the element remove (if the element was actually present). |
||||
|
||||
proc ::struct::set::S_exclude {Avar element} { |
||||
# Avar = Avar - {element} |
||||
upvar 1 $Avar A |
||||
if {![info exists A]} {return -code error "can't read \"$Avar\": no such variable"} |
||||
while {[::set pos [lsearch -exact $A $element]] >= 0} { |
||||
::set A [lreplace [K $A [::set A {}]] $pos $pos] |
||||
} |
||||
return |
||||
} |
||||
|
||||
# ::struct::set::S_add -- |
||||
# |
||||
# Add a set to a set. Similar to 'union', but the first argument |
||||
# is a variable. |
||||
# |
||||
# Parameters: |
||||
# Avar -- Reference to the set variable to extend. |
||||
# B -- The set to add to the set in Avar. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# The set in the variable referenced by Avar is extended |
||||
# by all the elements in B. |
||||
|
||||
proc ::struct::set::S_add {Avar B} { |
||||
# Avar = Avar + B |
||||
upvar 1 $Avar A |
||||
if {![info exists A]} {set A {}} |
||||
::set A [S_union [K $A [::set A {}]] $B] |
||||
return |
||||
} |
||||
|
||||
# ::struct::set::S_subtract -- |
||||
# |
||||
# Remove a set from a set. Similar to 'difference', but the first argument |
||||
# is a variable. |
||||
# |
||||
# Parameters: |
||||
# Avar -- Reference to the set variable to shrink. |
||||
# B -- The set to remove from the set in Avar. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# The set in the variable referenced by Avar is shrunk, |
||||
# all elements of B are removed. |
||||
|
||||
proc ::struct::set::S_subtract {Avar B} { |
||||
# Avar = Avar - B |
||||
upvar 1 $Avar A |
||||
if {![info exists A]} {return -code error "can't read \"$Avar\": no such variable"} |
||||
::set A [S_difference [K $A [::set A {}]] $B] |
||||
return |
||||
} |
||||
|
||||
# ::struct::set::S_subsetof -- |
||||
# |
||||
# A predicate checking if the first set is a subset |
||||
# or equal to the second set. |
||||
# |
||||
# Parameters: |
||||
# A -- The possible subset. |
||||
# B -- The set to compare to. |
||||
# |
||||
# Results: |
||||
# A boolean value, true if A is subset of or equal to B |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_subsetof {A B} { |
||||
# A subset|== B <=> (A == A*B) |
||||
return [S_equal $A [S_intersect $A $B]] |
||||
} |
||||
|
||||
# ::struct::set::K -- |
||||
# Performance helper command. |
||||
|
||||
proc ::struct::set::K {x y} {::set x} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
namespace eval ::struct { |
||||
# Put 'set::set' into the general structure namespace |
||||
# for pickup by the main management. |
||||
|
||||
namespace import -force set::set_tcl |
||||
} |
||||
@ -0,0 +1,63 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application tcl9test 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
foreach base [tcl::tm::list] { |
||||
set nsprefix "";#in case sourced directly and not in any of the .tm paths |
||||
if {[string match -nocase ${base}* [info script]]} { |
||||
set nsprefix [string trimleft [join [lrange [file split [string range [info script] [string length $base]+1 end]] 0 end-1] ::]:: ::] |
||||
break |
||||
} |
||||
} |
||||
namespace eval [lassign [split [file rootname [file tail [info script] ]] -] pkgtail verparts]${nsprefix}$pkgtail { |
||||
#-------------------------------------- |
||||
#Do not put any 'package require' statements above this block. (globals nsprefix,pkgtail,verparts still set) |
||||
variable pkg "${::nsprefix}${::pkgtail}[unset ::nsprefix; unset ::pkgtail]" |
||||
variable version [join $::verparts -][unset ::verparts] |
||||
#-------------------------------------- |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
puts stdout "-->[info script]" |
||||
puts stdout "-->[namespace current]" |
||||
puts stdout "-->pkg $pkg" |
||||
puts stdout "-->version $version" |
||||
|
||||
|
||||
|
||||
|
||||
#<tcl-payload> |
||||
#</tcl-payload> |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
uplevel #0 [list package provide $pkg $version] |
||||
} |
||||
return |
||||
|
||||
#package provide tcl9test [namespace eval tcl9test { |
||||
# variable version |
||||
# set version 999999.0a1.0 |
||||
#}] |
||||
#return |
||||
@ -0,0 +1,13 @@
|
||||
%project% |
||||
============================== |
||||
|
||||
+ |
||||
+ |
||||
|
||||
|
||||
About |
||||
------------------------------ |
||||
|
||||
+ |
||||
+ |
||||
+ |
||||
@ -1,20 +1,20 @@
|
||||
Create multishell scripts from your .tcl .sh and .ps1 scripts that are stored here. |
||||
|
||||
Use the pmix wrap functions to generate a multishell .cmd file from your scripts. |
||||
This .cmd is a 'polyglot' script - it should run when called from any of the target interpreters. |
||||
|
||||
|
||||
A multishell .cmd file is a cross-platform script that can easily be run on Windows and unix-like platforms. |
||||
|
||||
The .cmd extension is primarily a convenience so that it can be run easily by name on windows but it is ok to either leave it as that on other platforms, or rename it appropriately. |
||||
|
||||
On unix-like platforms it can be called with a bourne shell such as sh or bash. |
||||
|
||||
On windows, it can also be called with sh or bash if they are available - but the usual method would be to run it under cmd.exe initially just by opening a cmd prompt and running it. |
||||
This will run some windows batch script to automatically generate a corresponding .ps1 file and execution will switch to powershell 5 or powershell 7 (pwsh) if available. |
||||
Subsequently the command can be run directly from powershell. |
||||
|
||||
Whether called from Bourne shell, or cmd.exe or powershell - the usual payload would be your wrapped Tcl code - but it's also possible for powershell or sh/bash to be the primary payload script. |
||||
Any of these languages could easily be used to detect and launch other scripts/utilities that you may distribute with your app. |
||||
|
||||
|
||||
Create multishell scripts from your .tcl .sh and .ps1 scripts that are stored here. |
||||
|
||||
Use the pmix wrap functions to generate a multishell .cmd file from your scripts. |
||||
This .cmd is a 'polyglot' script - it should run when called from any of the target interpreters. |
||||
|
||||
|
||||
A multishell .cmd file is a cross-platform script that can easily be run on Windows and unix-like platforms. |
||||
|
||||
The .cmd extension is primarily a convenience so that it can be run easily by name on windows but it is ok to either leave it as that on other platforms, or rename it appropriately. |
||||
|
||||
On unix-like platforms it can be called with a bourne shell such as sh or bash. |
||||
|
||||
On windows, it can also be called with sh or bash if they are available - but the usual method would be to run it under cmd.exe initially just by opening a cmd prompt and running it. |
||||
This will run some windows batch script to automatically generate a corresponding .ps1 file and execution will switch to powershell 5 or powershell 7 (pwsh) if available. |
||||
Subsequently the command can be run directly from powershell. |
||||
|
||||
Whether called from Bourne shell, or cmd.exe or powershell - the usual payload would be your wrapped Tcl code - but it's also possible for powershell or sh/bash to be the primary payload script. |
||||
Any of these languages could easily be used to detect and launch other scripts/utilities that you may distribute with your app. |
||||
|
||||
|
||||
|
||||
@ -0,0 +1,99 @@
|
||||
These wrappers are intended to be used with the pmix wrapper functions to automate wrapping of tcl,sh,powershell scripts into a polyglot script which will run in multiple environments |
||||
|
||||
You may also use these to hand-craft polyglot scripts. |
||||
|
||||
To override the default wrapper provided by the pmix command - you can create copies of the sample_ files and remove just the sample_ part |
||||
pmix wrap will then never wrap with latest version from the punk project - but only what you have in your scriptapps/wrappers folder. |
||||
|
||||
Alternatively you can copy the sample_ files and name them anything you like that doesn't begin with "punk-" |
||||
Then you can call the pmix wrap functions with the -template option and just the name of your file. |
||||
(only the scriptapps/wrappers folder will be used to locate your template) |
||||
|
||||
|
||||
You can create a yourscriptname.wrapconf file in the scriptapps folder alongside yourscriptname.tcl, yourscriptname.sh etc |
||||
This .wrapconf is only required if you need to do more complex wrapping. |
||||
|
||||
By default, with no yourscriptname.wrapconf found: |
||||
|
||||
yourscriptname.tcl will be substituted between |
||||
#<tcl-payload> |
||||
#</tcl-payload> |
||||
|
||||
yourscriptname.sh (if present) will be substituted between |
||||
#<shell-payload-pre-tcl> |
||||
#</shell-payload-pre-tcl> |
||||
|
||||
yourscriptname.ps1 (if present) will be substituted between |
||||
#<powershell-payload-pre-tcl> |
||||
#</powershell-payload-pre-tcl> |
||||
|
||||
|
||||
By providing a yourscriptname.wrapconf |
||||
you can specify the exact names of the files (in the scriptapps folder) that you want to include - and use more tags such as: |
||||
|
||||
#<shell-launch-tcl> |
||||
#</shell-launch-tcl> |
||||
|
||||
#<shell-payload-post-tcl> |
||||
#</shell-payload-post-tcl> |
||||
|
||||
|
||||
#<powershell-launch-tcl> |
||||
#/<powershell-launch-tcl> |
||||
|
||||
#<powershell-payload-post-tcl> |
||||
#</powershell-payload-post-tcl> |
||||
|
||||
The .wrapconf file can have comment lines (beginning with # and possibly whitespace) |
||||
|
||||
e.g myutility.wrapconf might contain: |
||||
#------------------------ |
||||
tagdata <shell-payload-pre-tcl> file myutility_download-tclkit2.sh |
||||
tagdata <shell-payload-pre-tcl> line {# code to verify download follows} |
||||
tagdata <shell-payload-pre-tcl> file myutility_download-tclkit2_verification.sh |
||||
tagdata <shell-launch-tcl> file myutility_launch-with-tclkit2.sh |
||||
tagdata <powershell-payload-pre-tcl> file myutility_download-tclkit2.ps1 |
||||
tagdata <powershell-launch-tcl> file myutility_launch-with-tclkit2.ps1 |
||||
|
||||
#------------------------ |
||||
|
||||
Where tagdata command uses the specified file contents to replace all the lines between the starting tag and corresponding closing tag |
||||
tagdata can be called multiple times per tag and each file/line is appended to the substitution lines for that tag |
||||
|
||||
It is an error to use the tagdata command on a self-closing tag (aka 'singleton' tag - such as <tag/> vs a paired set <tag> .. </tag> |
||||
|
||||
paired tags must have their opening and closing tags on different lines. |
||||
hence the following line is invalid. |
||||
# <mytag> something etc </mytag> # etc |
||||
This is because system is designed to allow repeated updates and analysis of existing output files. |
||||
i.e Tags are only supported in places where the languages will accept/ignore them (generally as part of comments) |
||||
This means it should be possible to reliably detect which template was used and when template upgrades/fixes can be safely applied in the presence of possibly tweaked non-template script data. |
||||
Possible exceptions are cases where 2 templates differ only in the default data on singleton-tag lines or default data between paired tags, and that default data has been replaced. |
||||
There are of course other more flexible/standard methods (e.g diff) to achieve this sort of thing - but this method was chosen to provide more explicit readability of where the insertion points are. |
||||
|
||||
singleton or paired tags can be replaced. |
||||
Failing to include the tag in the resultant line results in an error. |
||||
tagline can only be called once per tagname (e.g once for opening <tag> and once for closing </tag> or just once for self-closing tag <tag/>) |
||||
#------------------------ |
||||
#replacement of a singleton tag |
||||
tagline <batch-nextshell-line/> line {@set "nextshell=tclsh" & :: @<batch-nextshell-line/>} |
||||
#replacement of closing tag of a paired-tag |
||||
tagline </powershell-launch-tcl> line {#</powershell-launch-tcl> some comment or data} |
||||
#------------------------ |
||||
|
||||
|
||||
The .wrapconf could also specify a specific template in your scriptapps/wrappers folder e.g: |
||||
#------------------------ |
||||
template myutility-multishell.cmd |
||||
#------------------------ |
||||
|
||||
Leave template line out, or specify the defaults if you want to use the wrappers from the punk shell you are using. e.g |
||||
#------------------------ |
||||
template punk-multishell.cmd |
||||
#------------------------ |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@ -0,0 +1,112 @@
|
||||
: "[proc : args {}]" ;# *tcl shellbat - call with sh,bash,tclsh on any platform, or with cmd on windows. |
||||
: <<'HIDE_FROM_BASH_AND_SH' |
||||
: ;# leading colon hides from .bat, trailing slash hides next line from tcl \ |
||||
@call tclsh "%~dp0%~n0.bat" %* |
||||
: ;#\ |
||||
@set taskexitcode=%errorlevel% & goto :exit |
||||
# -*- tcl -*- |
||||
# ################################################################################################# |
||||
# This is a tcl shellbat file |
||||
# It is tuned to run when called as a batch file, a tcl script, an sh script or a bash script, |
||||
# so the specific layout and characters used are quite sensitive to change. |
||||
# It can be called on unix or windows platforms with or without the interpreter being specified on the commandline. |
||||
# e.g ./filename.sh.bat in sh or bash or powershell |
||||
# e.g filename.sh or filename.sh.bat at windows command prompt |
||||
# e.g tclsh filename.sh.bat | sh filename.sh.bat | bash filename.sh.bat |
||||
# In all cases an arbitrary number of arguments are accepted |
||||
# To avoid the initial commandline on stdout when calling as a batch file on windows, use: |
||||
# cmd /Q /c filename.sh.bat |
||||
# (because we cannot use @if to silence it, as this isn't understood by tcl,sh or bash) |
||||
# ################################################################################################# |
||||
#fconfigure stdout -translation crlf |
||||
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl Payload |
||||
#puts "script : [info script]" |
||||
#puts "argcount : $::argc" |
||||
#puts "argvalues: $::argv" |
||||
|
||||
|
||||
#<tcl-payload> |
||||
#<tcl-payload/> |
||||
|
||||
# --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
# only exit if needed. see exitcode notes at bottom of file and exit there for consistency across invocation methods |
||||
# --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl Payload |
||||
#-- |
||||
#-- bash/sh code follows. |
||||
#-- protect from tcl using line continuation char on the previous comment for each line, like so: \ |
||||
printf "etc" |
||||
#-- or alternatively place sh/bash script within the false==false block |
||||
#-- whilst being careful to balance braces {} |
||||
#-- For more complex needs you should call out to external scripts |
||||
#-- |
||||
#-- END marker for hide_from_bash_and_sh\ |
||||
HIDE_FROM_BASH_AND_SH |
||||
|
||||
#--------------------------------------------------------- |
||||
#-- This if statement hides(mostly) a sh/bash code block from Tcl |
||||
if false==false # else { |
||||
then |
||||
: |
||||
#--------------------------------------------------------- |
||||
#-- leave as is if all that's required is launching the Tcl payload" |
||||
#-- |
||||
#-- Note that sh/bash script isn't called when running a .bat from cmd.exe on windows by default |
||||
#-- adjust line 4: @call tclsh ... to something like @call sh ... @call bash .. or @call env sh ... etc as appropriate |
||||
#-- if sh/bash scripting needs to run on windows too. |
||||
#-- |
||||
#printf "start of bash or sh code" |
||||
|
||||
#<shell-payload-pre-tcl> |
||||
#</shell-payload-pre-tcl> |
||||
|
||||
|
||||
#-- sh/bash launches Tcl here instead of shebang line at top |
||||
#<shell-launch-tcl> |
||||
#-- use exec to use exitcode (if any) directly from the tcl script |
||||
exec /usr/bin/env tclsh "$0" "$@" |
||||
#</shell-launch-tcl> |
||||
|
||||
#-- alternative - if sh/bash script required to run after the tcl call. |
||||
#/usr/bin/env tclsh "$0" "$@" |
||||
#tcl_exitcode=$? |
||||
#echo "tcl_exitcode: ${tcl_exitcode}" |
||||
|
||||
#<shell-payload-post-tcl> |
||||
#</shell-payload-post-tcl> |
||||
|
||||
#-- override exitcode example |
||||
#exit 66 |
||||
|
||||
#printf "No need for trailing slashes for sh/bash code here\n" |
||||
#--------------------------------------------------------- |
||||
fi |
||||
# closing brace for Tcl } |
||||
#--------------------------------------------------------- |
||||
|
||||
#-- tcl and shell script now both active |
||||
|
||||
#-- comment for line sample 1 with trailing continuation slash \ |
||||
#printf "tcl-invisible sh/bash line sample 1 \n" |
||||
|
||||
#-- comment for line sample 2 with trailing continuation slash \ |
||||
#printf "tcl-invisible sh/bash line sample 2 \n" |
||||
|
||||
|
||||
#-- Consistent exitcode from sh,bash,tclsh or cmd |
||||
#-- Call exit in tcl (or sh/bash) code only if explicitly required, otherwise leave this commented out. |
||||
#-- (script might be more widely useable without explicit exit. e.g in tcl: set ::argc 1; set ::argv "val"; source filename.sh.bat ) |
||||
#-- exit line unprotected by trailing slash will work for tcl and/or sh/bash |
||||
#exit 0 |
||||
#exit 42 |
||||
|
||||
|
||||
|
||||
#-- make sure sh/bash/tcl all skip over .bat style exit \ |
||||
: <<'shell_end' |
||||
#-- .bat exit with exitcode from tcl process \ |
||||
:exit |
||||
: ;# \ |
||||
@exit /B %taskexitcode% |
||||
# .bat has exited \ |
||||
shell_end |
||||
|
||||
@ -0,0 +1,559 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::timeinterval 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# shamelessly grabbed from: |
||||
#https://wiki.tcl-lang.org/page/Measuring+time+intervals+%28between+two+timestamps%29+with+months+etc |
||||
# |
||||
namespace eval punk::timeinterval { |
||||
|
||||
proc clock_scan_interval { seconds delta units } { |
||||
# clock_scan_interval formats $seconds to a string for processing by clock scan |
||||
# then returns new timestamp in seconds |
||||
set stamp [clock format $seconds -format "%Y%m%dT%H%M%S"] |
||||
if { $delta < 0 } { |
||||
append stamp " - " [expr { abs( $delta ) } ] " " $units |
||||
} else { |
||||
append stamp " + " $delta " " $units |
||||
} |
||||
return [clock scan $stamp] |
||||
} |
||||
|
||||
namespace export difference |
||||
#wrap in dict |
||||
|
||||
proc difference {s1 s2} { |
||||
lassign [interval_ymdhs $s1 $s2] Y M D h m s |
||||
return [dict create years $Y months $M days $D hours $h minutes $m seconds $s] |
||||
} |
||||
|
||||
proc interval_ymdhs { s1 s2 } { |
||||
# interval_ymdhs calculates the interval of time between |
||||
# the earliest date and the last date |
||||
# by starting to count at the earliest date. |
||||
|
||||
# This proc has audit features. It will automatically |
||||
# attempt to correct and report any discrepancies it finds. |
||||
|
||||
# if s1 and s2 aren't in seconds, convert to seconds. |
||||
if { ![string is integer -strict $s1] } { |
||||
set s1 [clock scan $s1] |
||||
} |
||||
if { ![string is integer -strict $s2] } { |
||||
set s2 [clock scan $s2] |
||||
} |
||||
# postgreSQL intervals determine month length based on earliest date in interval calculations. |
||||
|
||||
# set s1 to s2 in chronological sequence |
||||
set sn_list [lsort -integer [list $s1 $s2]] |
||||
set s1 [lindex $sn_list 0] |
||||
set s2 [lindex $sn_list 1] |
||||
|
||||
# Arithmetic is done from most significant to least significant |
||||
# The interval is spanned in largest units first. |
||||
# A new position s1_pN is calculated for the Nth move along the interval. |
||||
# s1 is s1_p0 |
||||
|
||||
# Calculate years from s1_p0 to s2 |
||||
set y_count 0 |
||||
set s1_p0 $s1 |
||||
set s2_y_check $s1_p0 |
||||
while { $s2_y_check <= $s2 } { |
||||
set s1_p1 $s2_y_check |
||||
set y $y_count |
||||
incr y_count |
||||
set s2_y_check [clock_scan_interval $s1_p0 $y_count years] |
||||
} |
||||
# interval s1_p0 to s1_p1 counted in y years |
||||
|
||||
# is the base offset incremented one too much? |
||||
set s2_y_check [clock_scan_interval $s1 $y years] |
||||
if { $s2_y_check > $s2 } { |
||||
set y [expr { $y - 1 } ] |
||||
set s2_y_check [clock_scan_interval $s1 $y years] |
||||
} |
||||
# increment s1 (s1_p0) forward y years to s1_p1 |
||||
if { $y == 0 } { |
||||
set s1_p1 $s1 |
||||
} else { |
||||
set s1_p1 [clock_scan_interval $s1 $y years] |
||||
} |
||||
# interval s1 to s1_p1 counted in y years |
||||
|
||||
# Calculate months from s1_p1 to s2 |
||||
set m_count 0 |
||||
set s2_m_check $s1_p1 |
||||
while { $s2_m_check <= $s2 } { |
||||
set s1_p2 $s2_m_check |
||||
set m $m_count |
||||
incr m_count |
||||
set s2_m_check [clock_scan_interval $s1_p1 $m_count months] |
||||
} |
||||
# interval s1_p1 to s1_p2 counted in m months |
||||
|
||||
# Calculate interval s1_p2 to s2 in days |
||||
# day_in_sec [expr { 60 * 60 * 24 } ] |
||||
# 86400 |
||||
# Since length of month is not relative, use math. |
||||
# Clip any fractional part. |
||||
set d [expr { int( ( $s2 - $s1_p2 ) / 86400. ) } ] |
||||
# Ideally, this should always be true, but daylight savings.. |
||||
# so, go backward one day and make hourly steps for last day. |
||||
if { $d > 0 } { |
||||
incr d -1 |
||||
} |
||||
|
||||
# Move interval from s1_p2 to s1_p3 |
||||
set s1_p3 [clock_scan_interval $s1_p2 $d days] |
||||
# s1_p3 is less than a day from s2 |
||||
|
||||
|
||||
# Calculate interval s1_p3 to s2 in hours |
||||
# hour_in_sec [expr { 60 * 60 } ] |
||||
# 3600 |
||||
set h [expr { int( ( $s2 - $s1_p3 ) / 3600. ) } ] |
||||
# Move interval from s1_p3 to s1_p4 |
||||
set s1_p4 [clock_scan_interval $s1_p3 $h hours] |
||||
# s1_p4 is less than an hour from s2 |
||||
|
||||
|
||||
# Sometimes h = 24, yet is already included as a day! |
||||
# For example, this case: |
||||
# interval_ymdhs 20010410T000000 19570613T000000 |
||||
# from Age() example in PostgreSQL documentation: |
||||
# http://www.postgresql.org/docs/9.1/static/functions-datetime.html |
||||
# psql test=# select age(timestamp '2001-04-10', timestamp '1957-06-13'); |
||||
# age |
||||
# ------------------------- |
||||
# 43 years 9 mons 27 days |
||||
# (1 row) |
||||
# According to LibreCalc, the difference is 16007 days |
||||
#puts "s2=s1+16007days? [clock format [clock_scan_interval $s1 16007 days] -format %Y%m%dT%H%M%S]" |
||||
# ^ this calc is consistent with 16007 days |
||||
# So, let's ignore the Postgresql irregularity for now. |
||||
# Here's more background: |
||||
# http://www.postgresql.org/message-id/5A86CA18-593F-4517-BB83-995115A6A402@morth.org |
||||
# http://www.postgresql.org/message-id/200707060844.l668i89w097496@wwwmaster.postgresql.org |
||||
# So, Postgres had a bug.. |
||||
|
||||
# Sanity check: if over 24 or 48 hours, push it up to a day unit |
||||
set h_in_days [expr { int( $h / 24. ) } ] |
||||
if { $h >= 1 } { |
||||
# adjust hours to less than a day |
||||
set h [expr { $h - ( 24 * $h_in_days ) } ] |
||||
incr d $h_in_days |
||||
set h_correction_p 1 |
||||
} else { |
||||
set h_correction_p 0 |
||||
} |
||||
|
||||
# Calculate interval s1_p4 to s2 in minutes |
||||
# minute_in_sec [expr { 60 } ] |
||||
# 60 |
||||
set mm [expr { int( ( $s2 - $s1_p4 ) / 60. ) } ] |
||||
# Move interval from s1_p4 to s1_p5 |
||||
set s1_p5 [clock_scan_interval $s1_p4 $mm minutes] |
||||
|
||||
# Sanity check: if 60 minutes, push it up to an hour unit |
||||
if { $mm >= 60 } { |
||||
# adjust 60 minutes to 1 hour |
||||
# puts "interval_ymdhs: debug info mm - 60, h + 1" |
||||
set mm [expr { $mm - 60 } ] |
||||
incr h |
||||
set mm_correction_p 1 |
||||
} else { |
||||
set mm_correction_p 0 |
||||
} |
||||
|
||||
# Calculate interval s1_p5 to s2 in seconds |
||||
set s [expr { int( $s2 - $s1_p5 ) } ] |
||||
|
||||
# Sanity check: if 60 seconds, push it up to one minute unit |
||||
if { $s >= 60 } { |
||||
# adjust 60 minutes to 1 hour |
||||
set s [expr { $s - 60 } ] |
||||
incr mm |
||||
set s_correction_p 1 |
||||
} else { |
||||
set s_correction_p 0 |
||||
} |
||||
|
||||
set return_list [list $y $m $d $h $mm $s] |
||||
|
||||
# test results by adding difference to s1 to get s2: |
||||
set i 0 |
||||
set s1_test [clock format $s1 -format "%Y%m%dT%H%M%S"] |
||||
set signs_inconsistent_p 0 |
||||
foreach unit {years months days hours minutes seconds} { |
||||
set t_term [lindex $return_list $i] |
||||
if { $t_term != 0 } { |
||||
if { $t_term > 0 } { |
||||
append s1_test " + $t_term $unit" |
||||
} else { |
||||
append s1_test " - [expr { abs( $t_term ) } ] $unit" |
||||
set signs_inconsistent_p 1 |
||||
} |
||||
} |
||||
incr i |
||||
} |
||||
|
||||
set s2_test [clock scan $s1_test] |
||||
# puts "test s2 '$s2_test' from: '$s1_test'" |
||||
set counter 0 |
||||
while { $s2 ne $s2_test && $counter < 30 } { |
||||
set s2_diff [expr { $s2_test - $s2 } ] |
||||
puts "\ninterval_ymdhs: debug s1 $s1 s2 $s2 y $y m $m d $d h $h s $s s2_diff $s2_diff" |
||||
if { [expr { abs($s2_diff) } ] > 86399 } { |
||||
if { $s2_diff > 0 } { |
||||
incr d -1 |
||||
puts "interval_ymdhs: debug, audit adjustment. decreasing 1 day to $d" |
||||
} else { |
||||
incr d |
||||
puts "interval_ymdhs: debug, audit adjustment. increasing 1 day to $d" |
||||
} |
||||
} elseif { [expr { abs($s2_diff) } ] > 3599 } { |
||||
if { $s2_diff > 0 } { |
||||
incr h -1 |
||||
puts "interval_ymdhs: debug, audit adjustment. decreasing 1 hour to $h" |
||||
} else { |
||||
incr h |
||||
puts "interval_ymdhs: debug, audit adjustment. increasing 1 hour to $h" |
||||
} |
||||
} elseif { [expr { abs($s2_diff) } ] > 59 } { |
||||
if { $s2_diff > 0 } { |
||||
incr mm -1 |
||||
puts "interval_ymdhs: debug, audit adjustment. decreasing 1 minute to $mm" |
||||
} else { |
||||
incr mm |
||||
puts "interval_ymdhs: debug, audit adjustment. increasing 1 minute to $mm" |
||||
} |
||||
} elseif { [expr { abs($s2_diff) } ] > 0 } { |
||||
if { $s2_diff > 0 } { |
||||
incr s -1 |
||||
puts "interval_ymdhs: debug, audit adjustment. decreasing 1 second to $s" |
||||
} else { |
||||
incr s |
||||
puts "interval_ymdhs: debug, audit adjustment. increasing 1 second to $s" |
||||
} |
||||
} |
||||
|
||||
set return_list [list $y $m $d $h $mm $s] |
||||
# set return_list [list [expr { abs($y) } ] [expr { abs($m) } ] [expr { abs($d) } ] [expr { abs($h) } ] [expr { abs($mm) } ] [expr { abs($s) } ]] |
||||
|
||||
# test results by adding difference to s1 to get s2: |
||||
set i 0 |
||||
set s1_test [clock format $s1 -format "%Y%m%dT%H%M%S"] |
||||
foreach unit {years months days hours minutes seconds} { |
||||
set t_term [lindex $return_list $i] |
||||
if { $t_term != 0 } { |
||||
if { $t_term > 0 } { |
||||
append s1_test " + $t_term $unit" |
||||
} else { |
||||
append s1_test " - [expr { abs( $t_term ) } ] $unit" |
||||
} |
||||
} |
||||
incr i |
||||
} |
||||
set s2_test [clock scan $s1_test] |
||||
incr counter |
||||
} |
||||
if { ( $counter > 0 || $signs_inconsistent_p ) && ( $h_correction_p || $mm_correction_p || $s_correction_p ) } { |
||||
# puts "interval_ymdhs: Corrections in the main calculation were applied: h ${h_correction_p}, mm ${mm_correction_p}, s ${s_correction_p}" |
||||
} |
||||
if { $signs_inconsistent_p } { |
||||
puts "\ninterval_ymdhs: signs inconsistent y $y m $m d $d h $h mm $mm s $s" |
||||
} |
||||
if { $s2 eq $s2_test } { |
||||
return $return_list |
||||
} else { |
||||
set s2_diff [expr { $s2_test - $s2 } ] |
||||
puts "debug s1 $s1 s1_p1 $s1_p1 s1_p2 $s1_p2 s1_p3 $s1_p3 s1_p4 $s1_p4" |
||||
puts "debug y $y m $m d $d h $h mm $mm s $s" |
||||
puts "interval_ymdhs error: s2 is '$s2' but s2_test is '$s2_test' a difference of ${s2_diff} from s1 '$s1_test'." |
||||
# error "result audit fails" "error: s2 is $s2 but s2_test is '$s2_test' a difference of ${s2_diff} from: '$s1_test'." |
||||
} |
||||
} |
||||
|
||||
proc interval_ymdhs_w_units { t1 t2 } { |
||||
# interval_ymdhs_w_units |
||||
# returns interval_ymdhs values with units |
||||
set v_list [interval_ymdhs $t2 $t1] |
||||
set i 0 |
||||
set a "" |
||||
foreach f {years months days hours minutes seconds} { |
||||
append a "[lindex $v_list $i] $f \n" |
||||
incr i |
||||
} |
||||
return $a |
||||
} |
||||
|
||||
|
||||
proc interval_remains_ymdhs { s1 s2 } { |
||||
# interval_remains_ymdhs calculates the interval of time between |
||||
# the earliest date and the last date |
||||
# by starting to count at the last date and work backwards in time. |
||||
|
||||
# This proc has audit features. It will automatically |
||||
# attempt to correct and report any discrepancies it finds. |
||||
|
||||
# if s1 and s2 aren't in seconds, convert to seconds. |
||||
if { ![string is integer -strict $s1] } { |
||||
set s1 [clock scan $s1] |
||||
} |
||||
if { ![string is integer -strict $s2] } { |
||||
set s2 [clock scan $s2] |
||||
} |
||||
# set s1 to s2 in reverse chronological sequence |
||||
set sn_list [lsort -decreasing -integer [list $s1 $s2]] |
||||
set s1 [lindex $sn_list 0] |
||||
set s2 [lindex $sn_list 1] |
||||
|
||||
# Arithmetic is done from most significant to least significant |
||||
# The interval is spanned in largest units first. |
||||
# A new position s1_pN is calculated for the Nth move along the interval. |
||||
# s1 is s1_p0 |
||||
|
||||
# Calculate years from s1_p0 to s2 |
||||
set y_count 0 |
||||
set s1_p0 $s1 |
||||
set s2_y_check $s1_p0 |
||||
while { $s2_y_check > $s2 } { |
||||
set s1_p1 $s2_y_check |
||||
set y $y_count |
||||
incr y_count -1 |
||||
set s2_y_check [clock_scan_interval $s1_p0 $y_count years] |
||||
} |
||||
# interval s1_p0 to s1_p1 counted in y years |
||||
|
||||
|
||||
# Calculate months from s1_p1 to s2 |
||||
set m_count 0 |
||||
set s2_m_check $s1_p1 |
||||
while { $s2_m_check > $s2 } { |
||||
set s1_p2 $s2_m_check |
||||
set m $m_count |
||||
incr m_count -1 |
||||
set s2_m_check [clock_scan_interval $s1_p1 $m_count months] |
||||
} |
||||
# interval s1_p1 to s1_p2 counted in m months |
||||
|
||||
# Calculate interval s1_p2 to s2 in days |
||||
# day_in_sec [expr { 60 * 60 * 24 } ] |
||||
# 86400 |
||||
# Since length of month is not relative, use math. |
||||
# Clip any fractional part. |
||||
set d [expr { int( ceil( ( $s2 - $s1_p2 ) / 86400. ) ) } ] |
||||
# Ideally, this should always be true, but daylight savings.. |
||||
# so, go backward one day and make hourly steps for last day. |
||||
if { $d < 0 } { |
||||
incr d |
||||
} |
||||
|
||||
# Move interval from s1_p2 to s1_p3 |
||||
set s1_p3 [clock_scan_interval $s1_p2 $d days] |
||||
# s1_p3 is less than a day from s2 |
||||
|
||||
|
||||
# Calculate interval s1_p3 to s2 in hours |
||||
# hour_in_sec [expr { 60 * 60 } ] |
||||
# 3600 |
||||
set h [expr { int( ceil( ( $s2 - $s1_p3 ) / 3600. ) ) } ] |
||||
# Move interval from s1_p3 to s1_p4 |
||||
set s1_p4 [clock_scan_interval $s1_p3 $h hours] |
||||
# s1_p4 is less than an hour from s2 |
||||
|
||||
# Sanity check: if over 24 or 48 hours, push it up to a day unit |
||||
set h_in_days [expr { int( ceil( $h / 24. ) ) } ] |
||||
if { $h_in_days <= -1 } { |
||||
# adjust hours to less than a day |
||||
set h [expr { $h - ( 24 * $h_in_days ) } ] |
||||
incr d $h_in_days |
||||
set h_correction_p 1 |
||||
} else { |
||||
set h_correction_p 0 |
||||
} |
||||
|
||||
# Calculate interval s1_p4 to s2 in minutes |
||||
# minute_in_sec [expr { 60 } ] |
||||
# 60 |
||||
set mm [expr { int( ceil( ( $s2 - $s1_p4 ) / 60. ) ) } ] |
||||
# Move interval from s1_p4 to s1_p5 |
||||
set s1_p5 [clock_scan_interval $s1_p4 $mm minutes] |
||||
|
||||
# Sanity check: if 60 minutes, push it up to an hour unit |
||||
if { $mm <= -60 } { |
||||
# adjust 60 minutes to 1 hour |
||||
# puts "interval_remains_ymdhs: debug info mm + 60, h - 1" |
||||
set mm [expr { $mm + 60 } ] |
||||
incr h -1 |
||||
set mm_correction_p 1 |
||||
} else { |
||||
set mm_correction_p 0 |
||||
} |
||||
|
||||
# Calculate interval s1_p5 to s2 in seconds |
||||
set s [expr { $s2 - $s1_p5 } ] |
||||
|
||||
# Sanity check: if 60 seconds, push it up to one minute unit |
||||
if { $s <= -60 } { |
||||
# adjust 60 minutes to 1 hour |
||||
set s [expr { $s + 60 } ] |
||||
incr mm -1 |
||||
set s_correction_p 1 |
||||
} else { |
||||
set s_correction_p 0 |
||||
} |
||||
|
||||
set return_list [list $y $m $d $h $mm $s] |
||||
# set return_list [list [expr { abs($y) } ] [expr { abs($m) } ] [expr { abs($d) } ] [expr { abs($h) } ] [expr { abs($mm) } ] [expr { abs($s) } ]] |
||||
|
||||
# test results by adding difference to s1 to get s2: |
||||
set i 0 |
||||
set s1_test [clock format $s1 -format "%Y%m%dT%H%M%S"] |
||||
set signs_inconsistent_p 0 |
||||
foreach unit {years months days hours minutes seconds} { |
||||
set t_term [lindex $return_list $i] |
||||
if { $t_term != 0 } { |
||||
if { $t_term > 0 } { |
||||
append s1_test " + $t_term $unit" |
||||
set signs_inconsistent_p 1 |
||||
} else { |
||||
append s1_test " - [expr { abs( $t_term ) } ] $unit" |
||||
} |
||||
} |
||||
incr i |
||||
} |
||||
set s2_test [clock scan $s1_test] |
||||
|
||||
set counter 0 |
||||
while { $s2 ne $s2_test && $counter < 3 } { |
||||
set s2_diff [expr { $s2_test - $s2 } ] |
||||
puts "\ninterval_remains_ymdhs: debug s1 $s1 s2 $s2 y $y m $m d $d h $h s $s s2_diff $s2_diff" |
||||
if { [expr { abs($s2_diff) } ] >= 86399 } { |
||||
if { $s2_diff > 0 } { |
||||
incr d -1 |
||||
puts "interval_remains_ymdhs: debug, audit adjustment. decreasing 1 day to $d" |
||||
} else { |
||||
incr d |
||||
puts "interval_remains_ymdhs: debug, audit adjustment. increasing 1 day to $d" |
||||
} |
||||
} elseif { [expr { abs($s2_diff) } ] > 3599 } { |
||||
if { $s2_diff > 0 } { |
||||
incr h -1 |
||||
puts "interval_remains_ymdhs: debug, audit adjustment. decreasing 1 hour to $h" |
||||
} else { |
||||
incr h |
||||
puts "interval_remains_ymdhs: debug, audit adjustment. increasing 1 hour to $h" |
||||
} |
||||
} elseif { [expr { abs($s2_diff) } ] > 59 } { |
||||
if { $s2_diff > 0 } { |
||||
incr mm -1 |
||||
puts "interval_remains_ymdhs: debug, audit adjustment. decreasing 1 minute to $mm" |
||||
} else { |
||||
incr mm |
||||
puts "interval_remains_ymdhs: debug, audit adjustment. increasing 1 minute to $mm" |
||||
} |
||||
} elseif { [expr { abs($s2_diff) } ] > 0 } { |
||||
if { $s2_diff > 0 } { |
||||
incr s -1 |
||||
puts "interval_remains_ymdhs: debug, audit adjustment. decreasing 1 second to $s" |
||||
} else { |
||||
incr s |
||||
puts "interval_remains_ymdhs: debug, audit adjustment. increasing 1 second to $s" |
||||
} |
||||
} |
||||
|
||||
set return_list [list $y $m $d $h $mm $s] |
||||
# set return_list [list [expr { abs($y) } ] [expr { abs($m) } ] [expr { abs($d) } ] [expr { abs($h) } ] [expr { abs($mm) } ] [expr { abs($s) } ]] |
||||
|
||||
# test results by adding difference to s1 to get s2: |
||||
set i 0 |
||||
set s1_test [clock format $s1 -format "%Y%m%dT%H%M%S"] |
||||
foreach unit {years months days hours minutes seconds} { |
||||
set t_term [lindex $return_list $i] |
||||
if { $t_term != 0 } { |
||||
if { $t_term > 0 } { |
||||
append s1_test " + $t_term $unit" |
||||
} else { |
||||
append s1_test " - [expr { abs( $t_term ) } ] $unit" |
||||
} |
||||
} |
||||
incr i |
||||
} |
||||
set s2_test [clock scan $s1_test] |
||||
incr counter |
||||
} |
||||
if { ( $counter > 0 || $signs_inconsistent_p ) && ( $h_correction_p || $mm_correction_p || $s_correction_p ) } { |
||||
# puts "interval_remains_ymdhs: Corrections in the main calculation were applied: h ${h_correction_p}, mm ${mm_correction_p}, s ${s_correction_p}" |
||||
} |
||||
if { $signs_inconsistent_p } { |
||||
puts "\ninterval_remains_ymdhs: signs inconsistent y $y m $m d $d h $h mm $mm s $s" |
||||
} |
||||
if { $s2 eq $s2_test } { |
||||
return $return_list |
||||
} else { |
||||
set s2_diff [expr { $s2_test - $s2 } ] |
||||
puts "debug s1 $s1 s1_p1 $s1_p1 s1_p2 $s1_p2 s1_p3 $s1_p3 s1_p4 $s1_p4" |
||||
puts "debug y $y m $m d $d h $h mm $mm s $s" |
||||
puts "interval_remains_ymdhs error: s2 is '$s2' but s2_test is '$s2_test' a difference of ${s2_diff} from s1 '$s1_test'." |
||||
# error "result audit fails" "error: s2 is $s2 but s2_test is '$s2_test' a difference of ${s2_diff} from: '$s1_test'." |
||||
} |
||||
|
||||
} |
||||
|
||||
proc interval_remains_ymdhs_w_units { t1 t2 } { |
||||
# interval_remains_ymdhs_w_units |
||||
# returns interval_remains_ymdhs values with units |
||||
set v_list [interval_ymdhs $t2 $t1] |
||||
set i 0 |
||||
set a "" |
||||
foreach f {years months days hours minutes seconds} { |
||||
append a "[lindex $v_list $i] $f \n" |
||||
incr i |
||||
} |
||||
return $a |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::timeinterval [namespace eval punk::timeinterval { |
||||
variable version |
||||
set version 999999.0a1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,3 @@
|
||||
0.1.0 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
@ -0,0 +1,72 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application tcl9test 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
foreach base [tcl::tm::list] { |
||||
if {[string match -nocase "${base}*" [info script]]} { |
||||
set nsprefix [join [lrange [file split [string trimleft [string range [info script] [string length $base] end] /]] 0 end-1] ::] |
||||
if {[string length $nsprefix]} {set nsprefix ${nsprefix}::} |
||||
break |
||||
} |
||||
} |
||||
namespace eval [lassign [split [file rootname [file tail [info script] ]] -] pkgtail verparts]$nsprefix$pkgtail[unset pkgtail] { |
||||
#-------------------------------------- |
||||
#unset ::nsparts; unset ::base |
||||
variable pkg [namespace current] |
||||
variable pkgtail [namespace tail [namespace current]] |
||||
variable version [join $::verparts -][unset ::verparts] |
||||
#-------------------------------------- |
||||
|
||||
puts stdout "-->[info script]" |
||||
puts stdout "-->[namespace current]" |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
uplevel #0 [list package provide $pkgtail $version] |
||||
#package provide [lassign {tcl9test 999999.0a1.0} pkg ver]$pkg [namespace eval $pkg[set pkg {}] {list [variable version $::ver[set ::ver {}]]$version}] |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#package provide [lassign {tcl9test 999999.0a1.0} pkg ver]$pkg [namespace eval $pkg[set pkg {}] {list [variable version $::ver[set ::ver {}]]$version}] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
#package provide tcl9test [namespace eval tcl9test { |
||||
# variable version |
||||
# set version 999999.0a1.0 |
||||
#}] |
||||
#return |
||||
@ -0,0 +1,3 @@
|
||||
0.1.0 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
@ -0,0 +1,246 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application winlibreoffice 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
package require uri ;#tcllib |
||||
|
||||
#windows? REVIEW - can we provide a common api for other platforms with only script? tcluno instead? |
||||
|
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
if {[catch {package require twapi}]} { |
||||
puts stderr "Twapi package required for winlibreoffice to function" |
||||
puts stderr "Minimal functionality - only some utils may work" |
||||
} |
||||
} else { |
||||
puts stderr "Package requires twapi. No current equivalent on non-windows platform. Try tcluno http://sf.net/projets/tcluno " |
||||
puts stderr "Minimal functionality - only some utils may work" |
||||
} |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval winlibreoffice { |
||||
#--- |
||||
#todo: investigate tcluno package http://sf.net/projects/tcluno |
||||
#CPlusPlus - platforms? |
||||
#--- |
||||
# |
||||
|
||||
#enable 1 |
||||
variable datebase "1899-12-30" ;#libreoffice default in options->LibreOfifce Calc->Calculate |
||||
#variable datebase "1900-01-01" ;#StarCalc 1.0 |
||||
#variable datebase "1904-01-01" ;# ??? |
||||
|
||||
#sometimes a com object may support $obj -print |
||||
#see also |
||||
# $obj -destroy |
||||
# $obj Quit |
||||
# $collection -iterate ?options? varname script |
||||
|
||||
variable uno "" ;# service manager object |
||||
variable psm "" ;# process service manager |
||||
|
||||
# -- --- --- --- |
||||
# libreoffice functions |
||||
proc getServiceManager {} { |
||||
variable uno |
||||
if {$uno eq ""} { |
||||
set uno [twapi::comobj com.sun.star.ServiceManager] |
||||
} |
||||
return $uno |
||||
} |
||||
#uno getAvailableServiceNames |
||||
|
||||
#e.g com.sun.star.beans.Introspection |
||||
# com.sun.star.ucb.SimpleFileAccess |
||||
proc createUnoService {objname} { |
||||
[getProcessServiceManager] createInstance $objname |
||||
} |
||||
proc getProcessServiceManager {} { |
||||
variable psm |
||||
if {$psm eq ""} { |
||||
set svcmgr [getServiceManager] |
||||
#set psm [$svcmgr getProcessServiceManager] |
||||
#seems to be same object? - it has createInstance anyway REVIEW |
||||
set psm $svcmgr |
||||
} |
||||
return $psm |
||||
} |
||||
|
||||
#what does libreoffice accept for this fun.. local file paths only? |
||||
proc convertToUrl {fpath} { |
||||
if {![string match "file:/*" $fpath]} { |
||||
# this turns //server/blah to file:////server/blah - which is probably nonsense |
||||
set fpath [uri::join scheme file path $fpath] |
||||
} |
||||
return $fpath |
||||
} |
||||
|
||||
#this |
||||
proc convertFromUrl {fileuri} { |
||||
if {[string match "file:/*" $fileuri]} { |
||||
set finfo [uri::split $fileuri] |
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
if {[dict exists $finfo host]} { |
||||
return "//${host}${path}" |
||||
} else { |
||||
#the leading slash in path indicates a local path and we strip on windows |
||||
set p [dict get $finfo path] |
||||
if {[string index $p 0] eq "/"} { |
||||
set p [string range $p 1 end] |
||||
} |
||||
return $p |
||||
} |
||||
} else { |
||||
if {[dict exists $finfo host]} { |
||||
#?? review - how are file uris to other hosts handled? |
||||
error "convertFromUrl doesn't handle non-local file uris on this platform" |
||||
} else { |
||||
return [dict get $finfo path] |
||||
} |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
# -- --- --- --- |
||||
# custom functions |
||||
proc get_desktop {} { |
||||
set uno [getServiceManager] |
||||
set ctx [$uno getPropertyValue "DefaultContext"] |
||||
set dt [$ctx getByName /singletons/com.sun.star.frame.theDesktop] |
||||
#$dt setName odk_officedev_desk |
||||
#$dt getName |
||||
return $dt |
||||
} |
||||
|
||||
proc blankdoc {{type scalc}} { |
||||
set known_types [list scalc swriter simpress sdraw smath] |
||||
if {$type ni $known_types} { |
||||
puts stderr "Warning: unknown type $type. (known types: $known_types) will try anyway - private:factory/$type" |
||||
} |
||||
set dt [get_desktop] |
||||
set doc [$dt loadComponentFromUrl "private:factory/$type" "_blank" 0 ""] ;#doesn't work without final param - empty string seems to work |
||||
puts "doc title: [$doc Title]" |
||||
return $doc |
||||
} |
||||
|
||||
proc file_open_dialog {{title "pick a libreoffice file"}} { |
||||
set filepicker [createUnoService "com.sun.star.ui.dialogs.FilePicker"] |
||||
$filepicker Title $title |
||||
set result [$filepicker Execute] |
||||
if {$result} { |
||||
#set files [$filepicker getSelectedFiles] |
||||
# -iterate ? |
||||
# return files(0) ? |
||||
|
||||
#e.g file:///C:/Users/sleek/test.txt |
||||
return [$filepicker getFiles] |
||||
} else { |
||||
return "" |
||||
} |
||||
} |
||||
|
||||
#todo oo interface? |
||||
proc calcdoc_sheets_by_index {doc idx} { |
||||
set sheets [$doc getSheets] |
||||
set s [$sheets getByIndex $idx] |
||||
puts stdout "Sheet: [$s getName]" |
||||
return $s |
||||
} |
||||
proc calcsheet_cell_range_by_name {sheet rangename} { |
||||
return [$sheet getCellRangeByName $rangename] ;#e.g A1 |
||||
} |
||||
proc calccell_setString {cell str} { |
||||
$cell setString $str |
||||
} |
||||
proc calccell_setValue {cell value} { |
||||
$cell setValue $value |
||||
} |
||||
proc calccell_setPropertyValue {cell propset} { |
||||
$cell setPropertyValue {*}$propset |
||||
#e.g "NumberFormat" 49 |
||||
# YYYY-MM-DD |
||||
} |
||||
|
||||
#a hack |
||||
#return libreoffice date in days since 1899.. |
||||
proc date_from_clockseconds_approx {cs} { |
||||
variable datebase |
||||
set tbase [clock scan $datebase] |
||||
package require punk::timeinterval |
||||
set diff [punk::timeinterval::difference $tbase $cs] |
||||
|
||||
set Y [dict get $diff years] |
||||
set M [dict get $diff months] |
||||
set D [dict get $diff days] |
||||
set yeardays [expr 365.25 * $Y] |
||||
set monthdays [expr 30.437 * $M] |
||||
|
||||
#yes.. this is horrible.. just a test really - but gets in the ballpark. |
||||
return [expr int($yeardays + $monthdays + $D)] |
||||
} |
||||
#time is represented on a scale of 0 to 1 6:00am = 0.25 (24/4) |
||||
|
||||
|
||||
proc date_from_clockseconds {cs} { |
||||
puts stderr "unimplemented" |
||||
|
||||
} |
||||
|
||||
#see also: https://wiki.tcl-lang.org/page/Tcom+examples+for+Microsoft+Outlook |
||||
# this also uses days since 1899 (but 31 dec?) and uses a fixed base_offset of 36526 (for 2000-01-01) - this might be a better approach than using punk::timeinterval anyway |
||||
# it seems to match libreoffice very closely (if not exact?) REVIEW |
||||
# wher val is days since 1899 |
||||
proc msdate_to_iso {val} { |
||||
set base_ticks [clock scan 20000101] |
||||
set base_offset 36526;# days since 31. Dec 1899, ARRRGGHHHHH |
||||
set offset [expr {int($val)-$base_offset}] |
||||
set clkdate [clock scan "$offset days" -base $base_ticks] |
||||
set isodate [clock format $clkdate -format %Y%m%d] |
||||
set fhours [expr {24.0*($val-int($val))}] |
||||
set hours [expr {int($fhours)}] |
||||
set mins [expr {int(($fhours-$hours)*60)}] |
||||
#date<sp>H:m is valid iso but not if space replaced with T - then would need seconds too |
||||
return "${isodate} $hours:$mins" |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide winlibreoffice [namespace eval winlibreoffice { |
||||
variable version |
||||
set version 999999.0a1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,3 @@
|
||||
0.1.0 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
@ -0,0 +1,902 @@
|
||||
#!/bin/sh |
||||
# the next line restarts using tclsh \ |
||||
exec tclsh "$0" ${1+"$@"} |
||||
|
||||
if { ![package vsatisfies [package provide Tcl] 8.5] } {puts stdout "Tcl: >= 8.5 is required"; return} |
||||
if { ![package vsatisfies [package require sha1] 2.0.3] } {puts stdout "sha1: >= 2.0.3 is required"; return} |
||||
if { ![package vsatisfies [package require yaml] 0.3.6] } {puts stdout "yaml: >= 0.3.6 is required"; return} |
||||
|
||||
namespace eval ::tcltm::binary { |
||||
proc readfile { dir file } { |
||||
set b [open [file normalize [filename $dir $file]]] |
||||
fconfigure $b -translation binary |
||||
fconfigure $b -encoding binary |
||||
set data [read $b] |
||||
close $b |
||||
return $data |
||||
} |
||||
proc filesize { dir file } { |
||||
return [string length [readfile $dir $file]] |
||||
} |
||||
proc filename { dir file } { |
||||
set f $file |
||||
if { [string match {*\**} $f] } { |
||||
set f [glob -directory $dir $f] |
||||
return $f |
||||
} |
||||
return [file normalize [file join $dir $file]] |
||||
} |
||||
proc hash { dir file } { |
||||
return [::sha1::sha1 -hex -file [filename $dir $file]] |
||||
} |
||||
proc encode { dir file } { |
||||
set info [dict create] |
||||
dict set info size [filesize $dir $file] |
||||
dict set info hash [hash $dir $file] |
||||
return $info |
||||
} |
||||
proc present { flist } { |
||||
return [expr {[llength [files $flist]] > 0 ? 1 : 0}] |
||||
} |
||||
proc files { flist } { |
||||
set filelist [list] |
||||
for {set fidx 0} {$fidx < [llength $flist]} {incr fidx} { |
||||
set fcfg [lindex $flist $fidx] |
||||
if { ![dict exists $fcfg type] } { |
||||
dict set fcfg type "script" |
||||
} |
||||
if { [string toupper [dict get $fcfg type]] eq "BINARY" } { |
||||
lappend filelist $fcfg |
||||
} |
||||
} |
||||
return $filelist |
||||
} |
||||
} |
||||
namespace eval ::tcltm::config { |
||||
proc exists { dir {cfg .tcltm} } { |
||||
set fname [file normalize [file join $dir $cfg]] |
||||
return [file exists $fname] |
||||
} |
||||
proc load { dir {cfg .tcltm} } { |
||||
set fname [file normalize [file join $dir $cfg]] |
||||
return [::yaml::yaml2dict -file $fname -m:true {1 {true on}} -m:false {0 {false off}}] |
||||
} |
||||
proc merge { cfg opts } { |
||||
dict set cfg options $opts |
||||
return $cfg |
||||
} |
||||
proc parse { cfg } { |
||||
set pkgs [list] |
||||
foreach p [dict get $cfg package] { |
||||
if { [dict exists $p filter] } { |
||||
set filter [list] |
||||
foreach {k v} [dict get $p filter] { |
||||
lappend filter "$k [::tcltm::env::resolve $v]" |
||||
} |
||||
dict set p filter $filter |
||||
} |
||||
set files [list] |
||||
foreach f [dict get $p files] { |
||||
if { [dict exists $f filter] } { |
||||
set filter [list] |
||||
foreach {k v} [dict get $f filter] { |
||||
lappend filter "$k [::tcltm::env::resolve $v]" |
||||
} |
||||
dict set f filter $filter |
||||
} |
||||
lappend files $f |
||||
} |
||||
dict set p files $files |
||||
if { [dict exists $p version] } { |
||||
dict set p version [::tcltm::env::resolve [dict get $p version]] |
||||
} |
||||
if { [dict get $cfg options version-from-index] } { |
||||
set idx [file normalize [file join [dict get $cfg options in] pkgIndex.tcl]] |
||||
if { [file exists $idx] } { |
||||
set results [::tcltm::scan $idx] |
||||
foreach {f res} $results { |
||||
if { $f eq $idx } { |
||||
foreach pkg $res { |
||||
if { [dict get $p name] eq [dict get $pkg package] && [dict get $pkg type] eq "ifneeded" } { |
||||
dict set p version [dict get $pkg version] |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
lappend pkgs $p |
||||
} |
||||
dict set cfg package $pkgs |
||||
return $cfg |
||||
} |
||||
} |
||||
namespace eval ::tcltm::env { |
||||
proc resolve { val } { |
||||
set v {} |
||||
if { [string tolower [string range $val 0 3]] eq "env:" } { |
||||
set l [split $val ":"] |
||||
if { [info exists ::env([lindex $l 1])] } { |
||||
set v $::env([lindex $l 1]) |
||||
} elseif { [llength $l] == 3 } { |
||||
set v [lindex $l 2] |
||||
} else { |
||||
error "environment variable '[lindex $l 1]' does not exists" |
||||
} |
||||
} else { |
||||
set v $val |
||||
} |
||||
return $v |
||||
} |
||||
} |
||||
namespace eval ::tcltm::filter { |
||||
proc line { str key value } { |
||||
regsub -all -- "@${key}@" $str $value str |
||||
return $str |
||||
} |
||||
proc lines { data key value } { |
||||
set lines [list] |
||||
foreach l [split $data "\n"] { |
||||
lappend lines [line $l $key $value] |
||||
} |
||||
return [join $lines "\n"] |
||||
} |
||||
proc multi { data args } { |
||||
set lines [list] |
||||
foreach l [split $data "\n"] { |
||||
set line $l |
||||
foreach {k v} $args { |
||||
set line [line $line $k $v] |
||||
} |
||||
lappend lines $line |
||||
} |
||||
return [join $lines "\n"] |
||||
} |
||||
proc lfile { pkg file } { |
||||
set filter [list] |
||||
if { [dict exists $pkg filter] } { |
||||
lappend filter [dict get $pkg filter] |
||||
} |
||||
foreach f [dict get $pkg files] { |
||||
if { [dict exists $f filter] && [dict get $f name] eq $file } { |
||||
lappend filter [dict get $f filter] |
||||
} |
||||
} |
||||
return $filter |
||||
} |
||||
} |
||||
namespace eval ::tcltm::license { |
||||
proc exists { dir {filename LICENSE} } { |
||||
set fname [file normalize [file join $dir $filename]] |
||||
return [file exists $fname] |
||||
} |
||||
proc load { dir {filename LICENSE} } { |
||||
set fname [file normalize [file join $dir $filename]] |
||||
set fh [open $fname RDONLY] |
||||
set data [read $fh] |
||||
close $fh |
||||
return $data |
||||
} |
||||
proc format { data } { |
||||
set license [list] |
||||
lappend license $::tcltm::markup::divider |
||||
foreach line [split $data "\n"] { |
||||
if { $line eq {} } { |
||||
lappend license "#" |
||||
} else { |
||||
lappend license [::tcltm::markup::comment $line] |
||||
} |
||||
} |
||||
lappend license $::tcltm::markup::divider |
||||
return $license |
||||
} |
||||
} |
||||
namespace eval ::tcltm::loader { |
||||
variable script { |
||||
namespace eval ::tcltm::binary { |
||||
variable path |
||||
variable resources |
||||
variable name |
||||
proc loader {} { |
||||
variable path |
||||
variable resources [list] |
||||
variable name |
||||
if { ![info exists path] || [string length $path] == 0 } { |
||||
set path [file normalize [file dirname [info script]]] |
||||
} |
||||
set bin [open [info script] {RDONLY BINARY}] |
||||
set header 0 |
||||
while { [gets $bin line] >= 0 } { |
||||
if { [string match {*TCLTM*HEADER*BEGIN*} $line] } { |
||||
set header 1 |
||||
continue |
||||
} |
||||
if { [string match {*TCLTM*HEADER*END*} $line] } { |
||||
break |
||||
} |
||||
if { [string match {*NAME*} $line] } { |
||||
regexp {^# ([[:alpha:]]+): ([[:alpha:]]+$)} $line -> - name |
||||
} |
||||
if { [string match {*RESOURCE*} $line] } { |
||||
set res {*}[string trimleft [lindex [split $line ":"] 1]] |
||||
dict lappend resources files [dict get $res NAME] |
||||
dict set resources [dict get $res NAME] $res |
||||
} |
||||
} |
||||
seek $bin 0 |
||||
set bindata [read $bin] |
||||
close $bin |
||||
set bindex [string first \\u001A $bindata] |
||||
incr bindex |
||||
foreach f [dict get $resources files] { |
||||
set finfo [dict get $resources $f] |
||||
set tmp [file normalize [file join $path [dict get $finfo NAME]]] |
||||
if { ![file exists [file dirname $tmp]] } { |
||||
file mkdir [file dirname $tmp] |
||||
} |
||||
set fh [open $tmp w] |
||||
fconfigure $fh -translation binary |
||||
fconfigure $fh -encoding binary |
||||
puts -nonewline $fh [string range $bindata $bindex [incr bindex [dict get $finfo SIZE]]-1] |
||||
flush $fh |
||||
close $fh |
||||
if { [package vsatisfies [package require sha1] 2.0.3] } { |
||||
set hash [::sha1::sha1 -hex -file $tmp] |
||||
if { $hash ne [dict get $finfo HASH] } { |
||||
return -code error "[file tail [info script]]: Hash invalid for embedded binary [dict get $finfo NAME]" |
||||
} |
||||
} |
||||
if { [dict exists $finfo ACTION] } { |
||||
switch -exact -- [string toupper [dict get $finfo ACTION]] { |
||||
NONE { |
||||
} |
||||
RUN { |
||||
if { [catch {source $tmp} err] } { |
||||
return -code error "Failed to run embedded resource: $tmp" |
||||
} |
||||
} |
||||
LOAD { |
||||
if { [catch {load $tmp}] } { |
||||
if { [catch {load $tmp $name}] } { |
||||
return -code error "[file tail [info script]]: failed to load embedded binary [dict get $finfo NAME]" |
||||
} |
||||
} |
||||
} |
||||
EXTRACT { |
||||
} |
||||
default { |
||||
} |
||||
} |
||||
} |
||||
incr bindex |
||||
} |
||||
} |
||||
} |
||||
} ; # END Variable script |
||||
variable action { |
||||
::tcltm::binary::loader |
||||
}; |
||||
variable interactive { |
||||
if { $tcl_interactive } { |
||||
::tcltm::binary::loader |
||||
} |
||||
} |
||||
} ; # END Namespace |
||||
namespace eval ::tcltm::markup { |
||||
variable divider [string repeat "#" 80] |
||||
proc comment { n args } { |
||||
set line {} |
||||
if { [llength $args] } { |
||||
set line [format {# %s %s} $n [join $args]] |
||||
} else { |
||||
set line [format {# %s} $n] |
||||
} |
||||
return $line |
||||
} |
||||
proc iscomment { line } { |
||||
if { [string index $line 0] eq "#" } { |
||||
return 1 |
||||
} |
||||
return 0 |
||||
} |
||||
proc nl {} { |
||||
return {} |
||||
} |
||||
proc meta { n args } { |
||||
if { [llength $args] } { |
||||
set line [format {# %s: %s} [string toupper $n] [join $args]] |
||||
} else { |
||||
set line [format {# %s} [string toupper $n]] |
||||
} |
||||
return $line |
||||
} |
||||
proc script { body args } { |
||||
regsub -all "\n$" $body {} body |
||||
return [string trimleft [format "[subst -nocommands -novariables $body]" {*}$args] "\n"] |
||||
} |
||||
} |
||||
namespace eval ::tcltm::module { |
||||
variable config [dict create] |
||||
variable content [list] |
||||
proc new { cfg pkg } { |
||||
variable config $cfg |
||||
variable content |
||||
set config $cfg |
||||
set content [list] |
||||
if { [dict exists [pkgcfg $pkg] interp] } { |
||||
lappend content "#!/usr/bin/env [dict get [pkgcfg $pkg] interp]" |
||||
lappend content [::tcltm::markup::comment "Windows Magic Header \\"] |
||||
lappend content "exec [dict get [pkgcfg $pkg] interp] \"\$0\" \"\$@\"" |
||||
lappend content [::tcltm::markup::nl] |
||||
} |
||||
lappend content [::tcltm::markup::comment "Tcl Module Generated by tcltm; DO NOT EDIT"] |
||||
lappend content [::tcltm::markup::nl] |
||||
return -code ok |
||||
} |
||||
proc pkgcfg { pkg } { |
||||
variable config |
||||
foreach p [dict get $config package] { |
||||
if { [dict get $p name] eq $pkg } { |
||||
return $p |
||||
} |
||||
} |
||||
return -code ok |
||||
} |
||||
proc write { pkg } { |
||||
variable config |
||||
variable content |
||||
variable cfg [pkgcfg $pkg] |
||||
set ext .tm |
||||
if { [dict exists $cfg extension] } { |
||||
set ext [dict get $cfg extension] |
||||
} |
||||
if { [dict exists $cfg finalname] && [string length [dict get $cfg finalname]] > 0 } { |
||||
set filename [dict get $cfg finalname] |
||||
} else { |
||||
if { [dict exists $cfg fileversion] } { |
||||
set fileversion [::tcltm::env::resolve [dict get $cfg fileversion]] |
||||
set filename [format {%s-%s%s} [dict get $cfg name] $fileversion $ext] |
||||
} else { |
||||
set filename [format {%s-%s%s} [dict get $cfg name] [dict get $cfg version] $ext] |
||||
} |
||||
} |
||||
regsub -all -- {::} $filename {/} filename |
||||
set filepath [file normalize [file join [file normalize [dict get $config options out]] $filename]] |
||||
if { [dict get $config options repo] } { |
||||
set tcldir "tcl[lindex [split [dict get $cfg tcl] "."] 0]" |
||||
set outdir [file normalize [file join [dict get $config options out] $tcldir [dict get $cfg tcl]]] |
||||
if { [catch {file mkdir $outdir} err] } { |
||||
puts stdout "Failed to create output directory ${outdir}: $err"; flush stdout |
||||
exit 1 |
||||
} |
||||
set filepath [file join $outdir $filename] |
||||
} |
||||
if { [catch {file mkdir [file dirname $filepath]} err] } { |
||||
puts stdout "Failed to create [file dirname $filepath]: $err" |
||||
exit 1 |
||||
} |
||||
if { [::tcltm::binary::present [dict get $cfg files]] } { |
||||
lappend content [::tcltm::markup::nl] |
||||
lappend content [::tcltm::markup::comment "BINARY SECTION"] |
||||
} |
||||
set fh [open $filepath w] |
||||
fconfigure $fh -translation lf |
||||
set lines [join $content "\n"] |
||||
regsub -all -- {\n\n\n+} $lines "\n\n" lines |
||||
puts $fh $lines |
||||
if { [::tcltm::binary::present [dict get $cfg files]] } { |
||||
puts -nonewline $fh "\u001A" |
||||
fconfigure $fh -translation binary |
||||
set binfiles [::tcltm::binary::files [dict get $cfg files]] |
||||
foreach f $binfiles { |
||||
puts stdout "Encoding: [dict get $f name]" |
||||
puts $fh [::tcltm::binary::readfile [dict get $config options in] [dict get $f name]] |
||||
} |
||||
} |
||||
close $fh |
||||
puts stdout "Module: $filename \[$filepath\]" |
||||
return -code ok |
||||
} |
||||
proc license { pkg } { |
||||
variable config |
||||
variable content |
||||
variable cfg [pkgcfg $pkg] |
||||
if { ![dict exists $cfg license] || [string length [dict get $cfg license]] == 0 } { |
||||
if { [::tcltm::license::exists [dict get $config options in]] } { |
||||
dict set cfg license [::tcltm::license::load [dict get $config options in]] |
||||
} |
||||
} |
||||
if { [dict exists $cfg license] && [string length [dict get $cfg license]] > 0 } { |
||||
if { [llength [split [dict get $cfg license] "\n"]] == 1 } { |
||||
dict set cfg license [::tcltm::license::load [dict get $config options in] [dict get $cfg license]] |
||||
} |
||||
} |
||||
if { [dict exists $cfg license] && [string length [dict get $cfg license]] > 0 } { |
||||
lappend content {*}[::tcltm::license::format [dict get $cfg license]] |
||||
lappend content [::tcltm::markup::nl] |
||||
} |
||||
return -code ok |
||||
} |
||||
proc header { pkg } { |
||||
variable config |
||||
variable content |
||||
variable cfg [pkgcfg $pkg] |
||||
lappend content [::tcltm::markup::comment "TCLTM HEADER BEGIN"] |
||||
foreach key {name version summary description Tcl} { |
||||
if { [dict exists $cfg $key] && [string length [dict get $cfg $key]] > 0 } { |
||||
if { [string tolower $key] eq "description" } { |
||||
foreach line [split [dict get $cfg $key] "\n"] { |
||||
lappend content [::tcltm::markup::meta "DESCRIPTION" $line] |
||||
} |
||||
} else { |
||||
lappend content [::tcltm::markup::meta $key [dict get $cfg $key]] |
||||
} |
||||
} |
||||
} |
||||
if { [dict exists $cfg dependencies] && [string length [dict get $cfg dependencies]] > 0 } { |
||||
foreach r [dict get $cfg dependencies] { |
||||
lappend content [::tcltm::markup::meta "REQUIRE" $r] |
||||
} |
||||
} |
||||
set files [list] |
||||
set bidx 0 |
||||
for {set fidx 0} {$fidx < [llength [dict get $cfg files]]} {incr fidx} { |
||||
set fcfg [lindex [dict get $cfg files] $fidx] |
||||
if { ![dict exists $fcfg type] } { |
||||
dict set fcfg type "script" |
||||
} |
||||
if { [string toupper [dict get $fcfg type]] eq "BINARY" } { |
||||
dict set fcfg id $bidx |
||||
incr bidx |
||||
if { [string match {*\**} [dict get $fcfg name]] } { |
||||
set f [glob -directory [dict get $config options in] [dict get $fcfg name]] |
||||
dict set fcfg name [file tail $f] |
||||
} |
||||
set enc [::tcltm::binary::encode [dict get $config options in] [dict get $fcfg name]] |
||||
set fcfg [list {*}$fcfg {*}$enc] |
||||
set name [dict get $fcfg name] |
||||
if { [dict get $config options strip-resource-dir] } { |
||||
set name [file tail $name] |
||||
} |
||||
set header [format {ID %s NAME %s SIZE %s HASH %s} \ |
||||
[dict get $fcfg id] \ |
||||
$name \ |
||||
[dict get $fcfg size] \ |
||||
[dict get $fcfg hash] \ |
||||
] |
||||
if { [dict exists $fcfg action] } { |
||||
append header " ACTION [dict get $fcfg action]" |
||||
} |
||||
if { [dict exists $fcfg target] } { |
||||
append header " TARGET [dict get $fcfg target]" |
||||
} |
||||
lappend content [::tcltm::markup::meta "RESOURCE" [format "{%s}" $header]] |
||||
} |
||||
lappend files $fcfg |
||||
} |
||||
lappend content [::tcltm::markup::comment "TCLTM HEADER END"] |
||||
return -code ok |
||||
} |
||||
proc satisfy-tcl-version { pkg } { |
||||
variable config |
||||
variable content |
||||
variable cfg [pkgcfg $pkg] |
||||
if { ![dict get $config options exclude-satisfy-tcl] } { |
||||
lappend content [::tcltm::markup::nl] |
||||
lappend content [::tcltm::markup::script { |
||||
if { ![package vsatisfies [package provide Tcl] %s] } { |
||||
return -code error "Unable to load module '%s' Tcl: '%s' is required" |
||||
} |
||||
} [dict get $cfg tcl] [dict get $cfg name] [dict get $cfg tcl]] |
||||
} |
||||
return -code ok |
||||
} |
||||
proc deps { pkg } { |
||||
variable config |
||||
variable content |
||||
variable cfg [pkgcfg $pkg] |
||||
if { ![dict get $config options exclude-deps] } { |
||||
if { [dict exists $cfg dependencies] && [string length [dict get $cfg dependencies]] > 0 } { |
||||
lappend content [::tcltm::markup::nl] |
||||
foreach r [dict get $cfg dependencies] { |
||||
lappend content [::tcltm::markup::script {package require %s} $r] |
||||
} |
||||
} |
||||
} |
||||
return -code ok |
||||
} |
||||
proc script { pkg type } { |
||||
variable config |
||||
variable content |
||||
variable cfg [pkgcfg $pkg] |
||||
set filter [list] |
||||
lappend filter "PNAME [dict get $cfg name]" |
||||
if { [dict exists $cfg version] } { |
||||
lappend filter "PVERSION \"[dict get $cfg version]\"" |
||||
} |
||||
if { [dict exists $pkg filter] } { |
||||
lappend filter [dict get $pkg filter] |
||||
} |
||||
if { [dict exists $cfg $type] && [string length [dict get $cfg $type]] > 0 } { |
||||
lappend content [::tcltm::markup::nl] |
||||
lappend content [::tcltm::markup::comment "TCLTM [string toupper $type] BEGIN"] |
||||
if { [llength [split [dict get $cfg $type] "\n"]] == 1 } { |
||||
if { [string match "*.tcl" [lindex [split [dict get $cfg $type] "\n"] 0]] } { |
||||
set bfile [lindex [split [dict get $cfg $type] "\n"] 0] |
||||
foreach line [split [::tcltm::binary::readfile [dict get $config options in] [::tcltm::binary::filename [dict get $config options in] $bfile]] "\n"] { |
||||
if { [dict get $config options strip] && [::tcltm::markup::iscomment $line] } { |
||||
} else { |
||||
foreach elm $filter { |
||||
set k [lindex $elm 0] |
||||
set v [lindex $elm 1] |
||||
set line [::tcltm::filter::line $line $k "$v"] |
||||
} |
||||
lappend content $line |
||||
} |
||||
} |
||||
} else { |
||||
lappend content [::tcltm::markup::script [dict get $cfg $type]] |
||||
} |
||||
} else { |
||||
foreach line [split [dict get $cfg $type] "\n"] { |
||||
if { [dict get $config options strip] && [::tcltm::markup::iscomment $line] } { |
||||
} else { |
||||
foreach elm $filter { |
||||
set k [lindex $elm 0] |
||||
set v [lindex $elm 1] |
||||
set line [::tcltm::filter::line $line $k $v] |
||||
} |
||||
lappend content [::tcltm::markup::script $line] |
||||
} |
||||
} |
||||
} |
||||
lappend content [::tcltm::markup::comment "TCLTM [string toupper $type] END"] |
||||
} |
||||
return -code ok |
||||
} |
||||
proc code { pkg } { |
||||
variable config |
||||
variable content |
||||
variable cfg [pkgcfg $pkg] |
||||
lappend content [::tcltm::markup::nl] |
||||
lappend content [::tcltm::markup::comment "TCLTM SCRIPT SECTION BEGIN"] |
||||
foreach f [dict get $cfg files] { |
||||
set inc 0 |
||||
if { [file extension [::tcltm::binary::filename [dict get $config options in] [dict get $f name]]] eq ".tcl" } { |
||||
set inc 1 |
||||
} elseif { [dict exists $f type] && [string tolower [dict get $f type]] eq "script" } { |
||||
set inc 1 |
||||
} |
||||
set filter [list] |
||||
if { [dict exists $f filtering] && [dict get $f filtering] } { |
||||
set filter {*}[::tcltm::filter::lfile $cfg [dict get $f name]] |
||||
lappend filter "PNAME [dict get $cfg name]" |
||||
if { [dict exists $cfg version] } { |
||||
lappend filter "PVERSION \"[dict get $cfg version]\"" |
||||
} |
||||
lappend filter "FILENAME [dict get $f name]" |
||||
} |
||||
if { $inc } { |
||||
set ignore(block) 0 |
||||
set ignore(next) 0 |
||||
foreach line [split [::tcltm::binary::readfile [dict get $config options in] [dict get $f name]] "\n"] { |
||||
if { [string match {*TCLTM*IGNORE*BEGIN*} [string toupper $line]] } { |
||||
set ignore(block) 1 |
||||
continue |
||||
} |
||||
if { [string match {*TCLTM*IGNORE*END*} [string toupper $line]] } { |
||||
set ignore(block) 0 |
||||
continue |
||||
} |
||||
if { $ignore(block) } { |
||||
continue |
||||
} |
||||
if { [string match {*TCLTM*IGNORE*NEXT*} [string toupper $line]] } { |
||||
set ignore(next) 1 |
||||
continue |
||||
} |
||||
if { $ignore(next) } { |
||||
set ignore(next) 0 |
||||
continue |
||||
} |
||||
if { [string match {*TCLTM*IGNORE*} [string toupper $line]] } { |
||||
continue |
||||
} |
||||
if { [dict get $config options strip] && [::tcltm::markup::iscomment $line] } { |
||||
} else { |
||||
if { ![regexp {^(?:([[:blank:]]+)?)package provide*} $line] } { |
||||
if { ![dict get $config options preserve-require] && [regexp {^(?:([[:blank:]]+)?)package require*} $line] } { |
||||
} |
||||
if { [dict exists $f filtering] && [dict get $f filtering] } { |
||||
foreach elm $filter { |
||||
set k [lindex $elm 0] |
||||
set v [lindex $elm 1] |
||||
set line [::tcltm::filter::line $line $k $v] |
||||
} |
||||
} |
||||
lappend content $line |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
lappend content [::tcltm::markup::comment "TCLTM SCRIPT SECTION END"] |
||||
return -code ok |
||||
} |
||||
proc pkg-provide { pkg } { |
||||
variable config |
||||
variable content |
||||
variable cfg [pkgcfg $pkg] |
||||
if { ![dict get $config options exclude-provide] } { |
||||
if { [dict exists $cfg version] } { |
||||
lappend content [::tcltm::markup::nl] |
||||
lappend content [::tcltm::markup::script {package provide %s %s} [dict get $cfg name] [dict get $cfg version]] |
||||
} else { |
||||
puts stdout "Skipping Package Provide due to missing version information" |
||||
} |
||||
} |
||||
return -code ok |
||||
} |
||||
proc binaryloader { pkg } { |
||||
variable config |
||||
variable content |
||||
variable cfg [pkgcfg $pkg] |
||||
if { [::tcltm::binary::present [dict get $cfg files]] } { |
||||
lappend content [::tcltm::markup::nl] |
||||
lappend content [::tcltm::markup::comment "TCLTM BINARY LOADER BEGIN"] |
||||
lappend content [::tcltm::markup::script $::tcltm::loader::script] |
||||
if { [dict get $config options interactive-loader] } { |
||||
lappend content [::tcltm::markup::script $::tcltm::loader::interactive] |
||||
} else { |
||||
lappend content [::tcltm::markup::script $::tcltm::loader::action] |
||||
} |
||||
lappend content [::tcltm::markup::comment "TCLTM BINARY LOADER END"] |
||||
} |
||||
return -code ok |
||||
} |
||||
} |
||||
namespace eval ::tcltm { |
||||
proc scan { args } { |
||||
set results [dict create] |
||||
set f [file normalize [lindex $args 0]] |
||||
if { ![file exists $f] } { |
||||
puts stdout "File '$f' does not exists" |
||||
exit 1 |
||||
} |
||||
set files $f |
||||
if { [file isdirectory $f] } { |
||||
set files [glob -nocomplain -directory $f -types f -- *.tcl] |
||||
} |
||||
foreach f $files { |
||||
set res [dict create] |
||||
set b [open $f] |
||||
fconfigure $b -translation binary |
||||
fconfigure $b -encoding binary |
||||
set data [read $b] |
||||
close $b |
||||
set pkgs [list] |
||||
foreach line [split $data "\n"] { |
||||
set r [dict create] |
||||
if { [regexp {package (provide|require|ifneeded)(?:[[:blank:]]+)([_[:alpha:]][:_[:alnum:]]*)(?:\])?((?:[[:blank:]]+)?(?:(\d+\.)?(\d+\.)?(\*|\d+))?)} $line -> type pkg ver] } { |
||||
dict set r type $type |
||||
dict set r package $pkg |
||||
dict set r version [string trim $ver] |
||||
lappend pkgs $r |
||||
} |
||||
} |
||||
dict set results $f $pkgs |
||||
} |
||||
return $results |
||||
} |
||||
} |
||||
namespace eval ::tcltm { |
||||
variable version |
||||
variable commit |
||||
|
||||
proc usage {} { |
||||
puts stdout [subst { |
||||
NAME: |
||||
tcltm - Tcl Module Builder |
||||
|
||||
USAGE: |
||||
tcltm ?options? |
||||
|
||||
VERSION: |
||||
$::tcltm::version ($::tcltm::commit) |
||||
|
||||
OPTIONS: |
||||
-i DIR, --in DIR Input directory. (Defaults: current directory) |
||||
-o DIR, --out DIR Output directory. (Defaults: current directory) |
||||
-c FILE, --config FILE Alternate config file. (Defaults: .tcltm) |
||||
-p NAME, --pkg NAME Only build package <NAME> from config. |
||||
(Defaults: build all) |
||||
|
||||
--version-from-index Use package version from pkgIndex.tcl |
||||
Only works when package name between config and |
||||
pkgIndex.tcl is the same. |
||||
--strip-comments Strip comments from source |
||||
--strip-resource-dir Strip the directory from the source files. |
||||
--exclude-satisfy-tcl Exclude Tcl vsatisfies command |
||||
--exclude-deps Exclude package require commands for dependencies |
||||
--exclude-provide Exclude package provide command |
||||
|
||||
--preserve-require Preserve 'package require' in source code. |
||||
|
||||
--interactive-loader Enable interactive loader. |
||||
Interactive loader will only run the binary loader when |
||||
the tcl interpreter is in interactive mode. |
||||
|
||||
--repository Create repository output directories. |
||||
(tcl8/tcl<version>/module.tm) |
||||
|
||||
--scan FILE Scan FILE for Tcl dependencies. |
||||
If file is a directory, all .tcl files in the |
||||
directory will be scanned. |
||||
|
||||
--verbose Verbose logging |
||||
--version Show version |
||||
-h, --help Show help |
||||
}] |
||||
} |
||||
|
||||
proc main { args } { |
||||
array set options { |
||||
in {} |
||||
out {} |
||||
config {.tcltm} |
||||
pkg {} |
||||
strip 0 |
||||
strip-resource-dir 0 |
||||
version-from-index 0 |
||||
exclude-satisfy-tcl 0 |
||||
exclude-deps 0 |
||||
exclude-provide 0 |
||||
preserve-require 0 |
||||
interactive-loader 0 |
||||
repo 0 |
||||
scan {} |
||||
verbose 0 |
||||
help 0 |
||||
version 0 |
||||
} |
||||
|
||||
while { [llength $args] } { |
||||
switch -glob -- [lindex $args 0] { |
||||
-i - |
||||
--in {set args [lassign $args - options(in)]} |
||||
-o - |
||||
--out {set args [lassign $args - options(out)]} |
||||
-c - |
||||
--config {set args [lassign $args - options(config)]} |
||||
-p - |
||||
--pkg {set args [lassign $args - options(pkg)]} |
||||
|
||||
--version-from-index {set options(version-from-index) 1; set args [lrange $args 1 end]} |
||||
--strip-comments {set options(strip) 1; set args [lrange $args 1 end]} |
||||
--strip-resource-dir {set options(strip-resource-dir) 1; set args [lrange $args 1 end]} |
||||
--exclude-satisfy-tcl {set options(exclude-satisfy-tcl) 1; set args [lrange $args 1 end]} |
||||
--exclude-deps {set options(exclude-deps) 1; set args [lrange $args 1 end]} |
||||
--exclude-provide {set options(exclude-provide) 1; set args [lrange $args 1 end]} |
||||
--preserve-require {set options(preserve-require) 1; set args [lrange $args 1 end]} |
||||
--repository {set options(repo) 1; set args [lrange $args 1 end]} |
||||
--interactive-loader {set options(interactive-loader) 1; set args [lrange $args 1 end]} |
||||
|
||||
--scan {set args [lassign $args - options(scan)]} |
||||
|
||||
--verbose {set options(verbose) 1; set args [lrange $args 1 end]} |
||||
--version {set options(version) 1; set args [lrange $args 1 end]} |
||||
-h - |
||||
--help {set options(help) 1; set args [lrange $args 1 end]} |
||||
|
||||
-- {set args [lrange $args 1 end]; break} |
||||
-* {puts stdout "Unknown option [lindex $args 0]"; exit 1} |
||||
default {break} |
||||
} |
||||
} |
||||
|
||||
# Show version |
||||
if { $options(version) } { |
||||
puts stdout "$::tcltm::version ($::tcltm::commit)"; flush stdout |
||||
exit 0 |
||||
} |
||||
|
||||
# Show help is requested |
||||
if { $options(help) } { |
||||
usage |
||||
exit 1 |
||||
} |
||||
|
||||
# Scan for dependencies |
||||
if { [string length $options(scan)] > 0 } { |
||||
set res [::tcltm::scan {*}$options(scan)] |
||||
foreach {f r} $res { |
||||
puts stdout "File: $f" |
||||
foreach p $r { |
||||
puts stdout " Type: [dict get $p type]" |
||||
puts stdout " Package: [dict get $p package]" |
||||
puts stdout " Version: [dict get $p version]\n" |
||||
} |
||||
} |
||||
exit 0 |
||||
} |
||||
|
||||
# input/output directory validation |
||||
foreach dir {in out} { |
||||
if { [string length $options($dir)] == 0 } { |
||||
set options($dir) [file normalize [pwd]] |
||||
if { $options(verbose) } { |
||||
puts stdout "No ${dir}put directory provided" |
||||
puts stdout " => Using current working directory \[[file normalize [pwd]]\]" |
||||
flush stdout |
||||
} |
||||
} else { |
||||
if { ![file isdirectory $options($dir)] } { |
||||
puts stdout "$options($dir) is not a directory"; exit 1 |
||||
} |
||||
} |
||||
} |
||||
|
||||
# Locate configuration |
||||
if { ![::tcltm::config::exists $options(in) $options(config)] } { |
||||
puts stdout "Missing configuration: $options(config)"; exit 1 |
||||
} |
||||
|
||||
# Load configuration and merge with commandline options |
||||
if { $options(verbose) } { puts stdout "Loading Configuration" } |
||||
set config [::tcltm::config::load $options(in) $options(config)] |
||||
set config [::tcltm::config::merge $config [array get options]] |
||||
set config [::tcltm::config::parse $config] |
||||
|
||||
if { $options(verbose) } { puts stdout $config } |
||||
|
||||
# Compile all packages wihtin configuration |
||||
foreach p [dict get $config package] { |
||||
set pkg [dict get $p name] |
||||
if { [string length $options(pkg)] > 0 } { |
||||
if { $pkg ne $options(pkg) } { |
||||
continue |
||||
} |
||||
} |
||||
|
||||
puts stdout "Building: $pkg" |
||||
|
||||
# New Module |
||||
::tcltm::module::new $config $pkg |
||||
|
||||
# Handle LICENSE |
||||
::tcltm::module::license $pkg |
||||
|
||||
# Module Header |
||||
::tcltm::module::header $pkg |
||||
|
||||
# Module Satify Tcl Version |
||||
::tcltm::module::satisfy-tcl-version $pkg |
||||
|
||||
# Module Dependencies |
||||
::tcltm::module::deps $pkg |
||||
|
||||
# Module Bootstrap |
||||
::tcltm::module::script $pkg bootstrap |
||||
|
||||
# Binary Loader |
||||
::tcltm::module::binaryloader $pkg |
||||
|
||||
# Module Source Code |
||||
::tcltm::module::code $pkg |
||||
|
||||
# Module Init Script |
||||
::tcltm::module::script $pkg init |
||||
|
||||
# Module Provide |
||||
::tcltm::module::pkg-provide $pkg |
||||
|
||||
# Module Finalize |
||||
::tcltm::module::script $pkg finalize |
||||
|
||||
# Write Module |
||||
::tcltm::module::write $pkg |
||||
} |
||||
} |
||||
} |
||||
|
||||
::tcltm::main {*}$::argv |
||||
@ -0,0 +1,93 @@
|
||||
These wrappers are intended to be used with the pmix wrapper functions to automate wrapping of tcl,sh,powershell scripts into a polyglot script which will run in multiple environments |
||||
|
||||
You may also use these to hand-craft polyglot scripts. |
||||
|
||||
To override the default wrapper provided by the pmix command - you can create copies of the sample_ files and remove just the sample_ part |
||||
pmix wrap will then never wrap with latest version from the punk project - but only what you have in your scriptapps/wrappers folder. |
||||
|
||||
Alternatively you can copy the sample_ files and name them anything you like that doesn't begin with "punk-" |
||||
Then you can call the pmix wrap functions with the -template option and just the name of your file. |
||||
(only the scriptapps/wrappers folder will be used to locate your template) |
||||
|
||||
|
||||
You can create a yourscriptname.wrapconf file in the scriptapps folder alongside yourscriptname.tcl, yourscriptname.sh etc |
||||
This .wrapconf is only required if you need to do more complex wrapping. |
||||
|
||||
By default, with no yourscriptname.wrapconf found: |
||||
|
||||
yourscriptname.tcl will be substituted between |
||||
#<tcl-payload> |
||||
#</tcl-payload> |
||||
|
||||
yourscriptname.sh (if present) will be substituted between |
||||
#<shell-payload-pre-tcl> |
||||
#</shell-payload-pre-tcl> |
||||
|
||||
yourscriptname.ps1 (if present) will be substituted between |
||||
#<powershell-payload-pre-tcl> |
||||
#</powershell-payload-pre-tcl> |
||||
|
||||
|
||||
By providing a yourscriptname.wrapconf |
||||
you can specify the exact names of the files (in the scriptapps folder) that you want to include - and use more tags such as: |
||||
|
||||
#<shell-launch-tcl> |
||||
#</shell-launch-tcl> |
||||
|
||||
#<shell-payload-post-tcl> |
||||
#</shell-payload-post-tcl> |
||||
|
||||
|
||||
#<powershell-launch-tcl> |
||||
#/<powershell-launch-tcl> |
||||
|
||||
#<powershell-payload-post-tcl> |
||||
#</powershell-payload-post-tcl> |
||||
|
||||
The .wrapconf file can have comment lines (beginning with # and possibly whitespace) |
||||
|
||||
e.g myutility.wrapconf might contain: |
||||
#------------------------ |
||||
tagdata <shell-payload-pre-tcl> file myutility_download-tclkit2.sh |
||||
tagdata <shell-launch-tcl> file myutility_launch-with-tclkit2.sh |
||||
tagdata <powershell-payload-pre-tcl> file myutility_download-tclkit2.ps1 |
||||
tagdata <powershell-launch-tcl> file myutility_launch-with-tclkit2.ps1 |
||||
#------------------------ |
||||
|
||||
Where tagdata command uses the specified file contents to replace all the lines between the starting tag and corresponding closing tag |
||||
It is an error to use the tagdata command on a self-closing tag (aka 'singleton' tag - such as <tag/> vs a paired set <tag> .. </tag> |
||||
|
||||
paired tags must have their opening and closing tags on different lines. |
||||
hence the following line is invalid. |
||||
# <mytag> something etc </mytag> # etc |
||||
This is because system is designed to allow repeated updates and analysis of existing output files. |
||||
i.e Tags are only supported in places where the languages will accept/ignore them (generally as part of comments) |
||||
This means it should be possible to reliably detect which template was used and when template upgrades/fixes can be safely applied in the presence of possibly tweaked non-template script data. |
||||
Possible exceptions are cases where 2 templates differ only in the default data on singleton-tag lines or default data between paired tags, and that default data has been replaced. |
||||
There are of course other more flexible/standard methods (e.g diff) to achieve this sort of thing - but this method was chosen to provide more explicit readability of where the insertion points are. |
||||
|
||||
singleton or paired tags can be replaced. |
||||
Failing to include the tag in the resultant line results in an error. |
||||
#------------------------ |
||||
#replacement of a singleton tag |
||||
tagline <batch-nextshell-line/> line {@set "nextshell=tclsh" & :: @<batch-nextshell-line/>} |
||||
#replacement of closing tag of a paired-tag |
||||
tagline </powershell-launch-tcl> line {#</powershell-launch-tcl> some comment or data} |
||||
#------------------------ |
||||
|
||||
|
||||
The .wrapconf could also specify a specific template in your scriptapps/wrappers folder e.g: |
||||
#------------------------ |
||||
template myutility-multishell.cmd |
||||
#------------------------ |
||||
|
||||
Leave template line out, or specify the defaults if you want to use the wrappers from the punk shell you are using. e.g |
||||
#------------------------ |
||||
template punk-multishell.cmd |
||||
#------------------------ |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@ -0,0 +1,112 @@
|
||||
: "[proc : args {}]" ;# *tcl shellbat - call with sh,bash,tclsh on any platform, or with cmd on windows. |
||||
: <<'HIDE_FROM_BASH_AND_SH' |
||||
: ;# leading colon hides from .bat, trailing slash hides next line from tcl \ |
||||
@call tclsh "%~dp0%~n0.bat" %* |
||||
: ;#\ |
||||
@set taskexitcode=%errorlevel% & goto :exit |
||||
# -*- tcl -*- |
||||
# ################################################################################################# |
||||
# This is a tcl shellbat file |
||||
# It is tuned to run when called as a batch file, a tcl script, an sh script or a bash script, |
||||
# so the specific layout and characters used are quite sensitive to change. |
||||
# It can be called on unix or windows platforms with or without the interpreter being specified on the commandline. |
||||
# e.g ./filename.sh.bat in sh or bash or powershell |
||||
# e.g filename.sh or filename.sh.bat at windows command prompt |
||||
# e.g tclsh filename.sh.bat | sh filename.sh.bat | bash filename.sh.bat |
||||
# In all cases an arbitrary number of arguments are accepted |
||||
# To avoid the initial commandline on stdout when calling as a batch file on windows, use: |
||||
# cmd /Q /c filename.sh.bat |
||||
# (because we cannot use @if to silence it, as this isn't understood by tcl,sh or bash) |
||||
# ################################################################################################# |
||||
#fconfigure stdout -translation crlf |
||||
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl Payload |
||||
#puts "script : [info script]" |
||||
#puts "argcount : $::argc" |
||||
#puts "argvalues: $::argv" |
||||
|
||||
|
||||
#<tcl-payload> |
||||
#<tcl-payload/> |
||||
|
||||
# --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
# only exit if needed. see exitcode notes at bottom of file and exit there for consistency across invocation methods |
||||
# --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl Payload |
||||
#-- |
||||
#-- bash/sh code follows. |
||||
#-- protect from tcl using line continuation char on the previous comment for each line, like so: \ |
||||
printf "etc" |
||||
#-- or alternatively place sh/bash script within the false==false block |
||||
#-- whilst being careful to balance braces {} |
||||
#-- For more complex needs you should call out to external scripts |
||||
#-- |
||||
#-- END marker for hide_from_bash_and_sh\ |
||||
HIDE_FROM_BASH_AND_SH |
||||
|
||||
#--------------------------------------------------------- |
||||
#-- This if statement hides(mostly) a sh/bash code block from Tcl |
||||
if false==false # else { |
||||
then |
||||
: |
||||
#--------------------------------------------------------- |
||||
#-- leave as is if all that's required is launching the Tcl payload" |
||||
#-- |
||||
#-- Note that sh/bash script isn't called when running a .bat from cmd.exe on windows by default |
||||
#-- adjust line 4: @call tclsh ... to something like @call sh ... @call bash .. or @call env sh ... etc as appropriate |
||||
#-- if sh/bash scripting needs to run on windows too. |
||||
#-- |
||||
#printf "start of bash or sh code" |
||||
|
||||
#<shell-payload-pre-tcl> |
||||
#</shell-payload-pre-tcl> |
||||
|
||||
|
||||
#-- sh/bash launches Tcl here instead of shebang line at top |
||||
#<shell-launch-tcl> |
||||
#-- use exec to use exitcode (if any) directly from the tcl script |
||||
exec /usr/bin/env tclsh "$0" "$@" |
||||
#</shell-launch-tcl> |
||||
|
||||
#-- alternative - if sh/bash script required to run after the tcl call. |
||||
#/usr/bin/env tclsh "$0" "$@" |
||||
#tcl_exitcode=$? |
||||
#echo "tcl_exitcode: ${tcl_exitcode}" |
||||
|
||||
#<shell-payload-post-tcl> |
||||
#</shell-payload-post-tcl> |
||||
|
||||
#-- override exitcode example |
||||
#exit 66 |
||||
|
||||
#printf "No need for trailing slashes for sh/bash code here\n" |
||||
#--------------------------------------------------------- |
||||
fi |
||||
# closing brace for Tcl } |
||||
#--------------------------------------------------------- |
||||
|
||||
#-- tcl and shell script now both active |
||||
|
||||
#-- comment for line sample 1 with trailing continuation slash \ |
||||
#printf "tcl-invisible sh/bash line sample 1 \n" |
||||
|
||||
#-- comment for line sample 2 with trailing continuation slash \ |
||||
#printf "tcl-invisible sh/bash line sample 2 \n" |
||||
|
||||
|
||||
#-- Consistent exitcode from sh,bash,tclsh or cmd |
||||
#-- Call exit in tcl (or sh/bash) code only if explicitly required, otherwise leave this commented out. |
||||
#-- (script might be more widely useable without explicit exit. e.g in tcl: set ::argc 1; set ::argv "val"; source filename.sh.bat ) |
||||
#-- exit line unprotected by trailing slash will work for tcl and/or sh/bash |
||||
#exit 0 |
||||
#exit 42 |
||||
|
||||
|
||||
|
||||
#-- make sure sh/bash/tcl all skip over .bat style exit \ |
||||
: <<'shell_end' |
||||
#-- .bat exit with exitcode from tcl process \ |
||||
:exit |
||||
: ;# \ |
||||
@exit /B %taskexitcode% |
||||
# .bat has exited \ |
||||
shell_end |
||||
|
||||
@ -0,0 +1,200 @@
|
||||
# cksum.tcl - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net> |
||||
# |
||||
# Provides a Tcl only implementation of the unix cksum(1) command. This is |
||||
# similar to the sum(1) command but the algorithm is better defined and |
||||
# standardized across multiple platforms by POSIX 1003.2/D11.2 |
||||
# |
||||
# This command has been verified against the cksum command from the GNU |
||||
# textutils package version 2.0 |
||||
# |
||||
# ------------------------------------------------------------------------- |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# ------------------------------------------------------------------------- |
||||
|
||||
package require Tcl 8.5-; # tcl minimum version |
||||
|
||||
namespace eval ::crc { |
||||
namespace export cksum |
||||
|
||||
variable cksum_tbl [list 0x0 \ |
||||
0x04C11DB7 0x09823B6E 0x0D4326D9 0x130476DC 0x17C56B6B \ |
||||
0x1A864DB2 0x1E475005 0x2608EDB8 0x22C9F00F 0x2F8AD6D6 \ |
||||
0x2B4BCB61 0x350C9B64 0x31CD86D3 0x3C8EA00A 0x384FBDBD \ |
||||
0x4C11DB70 0x48D0C6C7 0x4593E01E 0x4152FDA9 0x5F15ADAC \ |
||||
0x5BD4B01B 0x569796C2 0x52568B75 0x6A1936C8 0x6ED82B7F \ |
||||
0x639B0DA6 0x675A1011 0x791D4014 0x7DDC5DA3 0x709F7B7A \ |
||||
0x745E66CD 0x9823B6E0 0x9CE2AB57 0x91A18D8E 0x95609039 \ |
||||
0x8B27C03C 0x8FE6DD8B 0x82A5FB52 0x8664E6E5 0xBE2B5B58 \ |
||||
0xBAEA46EF 0xB7A96036 0xB3687D81 0xAD2F2D84 0xA9EE3033 \ |
||||
0xA4AD16EA 0xA06C0B5D 0xD4326D90 0xD0F37027 0xDDB056FE \ |
||||
0xD9714B49 0xC7361B4C 0xC3F706FB 0xCEB42022 0xCA753D95 \ |
||||
0xF23A8028 0xF6FB9D9F 0xFBB8BB46 0xFF79A6F1 0xE13EF6F4 \ |
||||
0xE5FFEB43 0xE8BCCD9A 0xEC7DD02D 0x34867077 0x30476DC0 \ |
||||
0x3D044B19 0x39C556AE 0x278206AB 0x23431B1C 0x2E003DC5 \ |
||||
0x2AC12072 0x128E9DCF 0x164F8078 0x1B0CA6A1 0x1FCDBB16 \ |
||||
0x018AEB13 0x054BF6A4 0x0808D07D 0x0CC9CDCA 0x7897AB07 \ |
||||
0x7C56B6B0 0x71159069 0x75D48DDE 0x6B93DDDB 0x6F52C06C \ |
||||
0x6211E6B5 0x66D0FB02 0x5E9F46BF 0x5A5E5B08 0x571D7DD1 \ |
||||
0x53DC6066 0x4D9B3063 0x495A2DD4 0x44190B0D 0x40D816BA \ |
||||
0xACA5C697 0xA864DB20 0xA527FDF9 0xA1E6E04E 0xBFA1B04B \ |
||||
0xBB60ADFC 0xB6238B25 0xB2E29692 0x8AAD2B2F 0x8E6C3698 \ |
||||
0x832F1041 0x87EE0DF6 0x99A95DF3 0x9D684044 0x902B669D \ |
||||
0x94EA7B2A 0xE0B41DE7 0xE4750050 0xE9362689 0xEDF73B3E \ |
||||
0xF3B06B3B 0xF771768C 0xFA325055 0xFEF34DE2 0xC6BCF05F \ |
||||
0xC27DEDE8 0xCF3ECB31 0xCBFFD686 0xD5B88683 0xD1799B34 \ |
||||
0xDC3ABDED 0xD8FBA05A 0x690CE0EE 0x6DCDFD59 0x608EDB80 \ |
||||
0x644FC637 0x7A089632 0x7EC98B85 0x738AAD5C 0x774BB0EB \ |
||||
0x4F040D56 0x4BC510E1 0x46863638 0x42472B8F 0x5C007B8A \ |
||||
0x58C1663D 0x558240E4 0x51435D53 0x251D3B9E 0x21DC2629 \ |
||||
0x2C9F00F0 0x285E1D47 0x36194D42 0x32D850F5 0x3F9B762C \ |
||||
0x3B5A6B9B 0x0315D626 0x07D4CB91 0x0A97ED48 0x0E56F0FF \ |
||||
0x1011A0FA 0x14D0BD4D 0x19939B94 0x1D528623 0xF12F560E \ |
||||
0xF5EE4BB9 0xF8AD6D60 0xFC6C70D7 0xE22B20D2 0xE6EA3D65 \ |
||||
0xEBA91BBC 0xEF68060B 0xD727BBB6 0xD3E6A601 0xDEA580D8 \ |
||||
0xDA649D6F 0xC423CD6A 0xC0E2D0DD 0xCDA1F604 0xC960EBB3 \ |
||||
0xBD3E8D7E 0xB9FF90C9 0xB4BCB610 0xB07DABA7 0xAE3AFBA2 \ |
||||
0xAAFBE615 0xA7B8C0CC 0xA379DD7B 0x9B3660C6 0x9FF77D71 \ |
||||
0x92B45BA8 0x9675461F 0x8832161A 0x8CF30BAD 0x81B02D74 \ |
||||
0x857130C3 0x5D8A9099 0x594B8D2E 0x5408ABF7 0x50C9B640 \ |
||||
0x4E8EE645 0x4A4FFBF2 0x470CDD2B 0x43CDC09C 0x7B827D21 \ |
||||
0x7F436096 0x7200464F 0x76C15BF8 0x68860BFD 0x6C47164A \ |
||||
0x61043093 0x65C52D24 0x119B4BE9 0x155A565E 0x18197087 \ |
||||
0x1CD86D30 0x029F3D35 0x065E2082 0x0B1D065B 0x0FDC1BEC \ |
||||
0x3793A651 0x3352BBE6 0x3E119D3F 0x3AD08088 0x2497D08D \ |
||||
0x2056CD3A 0x2D15EBE3 0x29D4F654 0xC5A92679 0xC1683BCE \ |
||||
0xCC2B1D17 0xC8EA00A0 0xD6AD50A5 0xD26C4D12 0xDF2F6BCB \ |
||||
0xDBEE767C 0xE3A1CBC1 0xE760D676 0xEA23F0AF 0xEEE2ED18 \ |
||||
0xF0A5BD1D 0xF464A0AA 0xF9278673 0xFDE69BC4 0x89B8FD09 \ |
||||
0x8D79E0BE 0x803AC667 0x84FBDBD0 0x9ABC8BD5 0x9E7D9662 \ |
||||
0x933EB0BB 0x97FFAD0C 0xAFB010B1 0xAB710D06 0xA6322BDF \ |
||||
0xA2F33668 0xBCB4666D 0xB8757BDA 0xB5365D03 0xB1F740B4 ] |
||||
|
||||
variable uid |
||||
if {![info exists uid]} {set uid 0} |
||||
} |
||||
|
||||
# crc::CksumInit -- |
||||
# |
||||
# Create and initialize a cksum context. This is cleaned up when we |
||||
# call CksumFinal to obtain the result. |
||||
# |
||||
proc ::crc::CksumInit {} { |
||||
variable uid |
||||
set token [namespace current]::[incr uid] |
||||
upvar #0 $token state |
||||
array set state {t 0 l 0} |
||||
return $token |
||||
} |
||||
|
||||
proc ::crc::CksumUpdate {token data} { |
||||
variable cksum_tbl |
||||
upvar #0 $token state |
||||
set t $state(t) |
||||
binary scan $data c* r |
||||
foreach {n} $r { |
||||
set index [expr { (($t >> 24) ^ ($n & 0xFF)) & 0xFF }] |
||||
# Since the introduction of built-in bigInt support with Tcl |
||||
# 8.5, bit-shifting $t to the left no longer overflows, |
||||
# keeping it 32 bits long. The value grows bigger and bigger |
||||
# instead - a severe hit on performance. For this reason we |
||||
# do a bitwise AND against 0xFFFFFFFF at each step to keep the |
||||
# value within limits. |
||||
set t [expr {0xFFFFFFFF & (($t << 8) ^ [lindex $cksum_tbl $index])}] |
||||
incr state(l) |
||||
} |
||||
set state(t) $t |
||||
return |
||||
} |
||||
|
||||
proc ::crc::CksumFinal {token} { |
||||
variable cksum_tbl |
||||
upvar #0 $token state |
||||
set t $state(t) |
||||
for {set i $state(l)} {$i > 0} {set i [expr {$i>>8}]} { |
||||
set index [expr {(($t >> 24) ^ $i) & 0xFF}] |
||||
set t [expr {0xFFFFFFFF & (($t << 8) ^ [lindex $cksum_tbl $index])}] |
||||
} |
||||
unset state |
||||
return [expr {~$t & 0xFFFFFFFF}] |
||||
} |
||||
|
||||
# crc::Pop -- |
||||
# |
||||
# Pop the nth element off a list. Used in options processing. |
||||
# |
||||
proc ::crc::Pop {varname {nth 0}} { |
||||
upvar $varname args |
||||
set r [lindex $args $nth] |
||||
set args [lreplace $args $nth $nth] |
||||
return $r |
||||
} |
||||
|
||||
# Description: |
||||
# Provide a Tcl equivalent of the unix cksum(1) command. |
||||
# Options: |
||||
# -filename name - return a checksum for the specified file. |
||||
# -format string - return the checksum using this format string. |
||||
# -chunksize size - set the chunking read size |
||||
# |
||||
proc ::crc::cksum {args} { |
||||
array set opts [list -filename {} -channel {} -chunksize 4096 \ |
||||
-format %u -command {}] |
||||
while {[string match -* [set option [lindex $args 0]]]} { |
||||
switch -glob -- $option { |
||||
-file* { set opts(-filename) [Pop args 1] } |
||||
-chan* { set opts(-channel) [Pop args 1] } |
||||
-chunk* { set opts(-chunksize) [Pop args 1] } |
||||
-for* { set opts(-format) [Pop args 1] } |
||||
-command { set opts(-command) [Pop args 1] } |
||||
default { |
||||
if {[llength $args] == 1} { break } |
||||
if {[string compare $option "--"] == 0} { Pop args ; break } |
||||
set err [join [lsort [array names opts -*]] ", "] |
||||
return -code error "bad option \"option\": must be $err" |
||||
} |
||||
} |
||||
Pop args |
||||
} |
||||
|
||||
if {$opts(-filename) != {}} { |
||||
set opts(-channel) [open $opts(-filename) r] |
||||
fconfigure $opts(-channel) -translation binary |
||||
} |
||||
|
||||
if {$opts(-channel) == {}} { |
||||
|
||||
if {[llength $args] != 1} { |
||||
return -code error "wrong # args: should be\ |
||||
cksum ?-format string?\ |
||||
-channel chan | -filename file | string" |
||||
} |
||||
set tok [CksumInit] |
||||
CksumUpdate $tok [lindex $args 0] |
||||
set r [CksumFinal $tok] |
||||
|
||||
} else { |
||||
|
||||
set tok [CksumInit] |
||||
while {![eof $opts(-channel)]} { |
||||
CksumUpdate $tok [read $opts(-channel) $opts(-chunksize)] |
||||
} |
||||
set r [CksumFinal $tok] |
||||
|
||||
if {$opts(-filename) != {}} { |
||||
close $opts(-channel) |
||||
} |
||||
} |
||||
|
||||
return [format $opts(-format) $r] |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
package provide cksum 1.1.4 |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# Local variables: |
||||
# mode: tcl |
||||
# indent-tabs-mode: nil |
||||
# End: |
||||
Loading…
Reference in new issue