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 |
||||||
|
------------------------------ |
||||||
|
|
||||||
|
+ |
||||||
|
+ |
||||||
|
+ |
||||||
@ -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