From f2d2a4d615656891ae046af1c2dd88350c7781e4 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Mon, 4 Sep 2023 12:35:58 +1000 Subject: [PATCH] script wrapper, doc, make.tcl , shellthread fixes --- src/bootsupport/fileutil/decode-0.2.1.tm | 207 ---- src/bootsupport/fileutil/multi-0.1.tm | 28 - src/bootsupport/fileutil/multi/op-0.5.3.tm | 645 ------------ src/bootsupport/fileutil/paths-1.tm | 74 -- src/bootsupport/fileutil/traverse-0.6.tm | 504 ---------- src/bootsupport/lib/README.md | 2 + src/bootsupport/{ => modules}/README.md | 0 src/bootsupport/{ => modules}/cksum-1.1.4.tm | 2 +- src/bootsupport/modules/cmdline-1.5.2.tm | 933 ++++++++++++++++++ .../{ => modules}/fileutil-1.16.1.tm | 2 +- .../{ => modules}/punk/du-0.1.0.tm | 52 +- src/bootsupport/{ => modules}/punk/mix-0.2.tm | 125 ++- .../{ => modules}/punk/repo-0.1.0.tm | 0 .../{ => modules}/punk/winpath-0.1.0.tm | 0 src/bootsupport/modules/struct/set-2.2.3.tm | 189 ++++ src/bootsupport/modules/struct/sets.tcl | 189 ++++ src/bootsupport/modules/struct/sets_c.tcl | 93 ++ src/bootsupport/modules/struct/sets_tcl.tcl | 452 +++++++++ src/build.cmd | 275 ++++++ src/make.tcl | 32 +- src/modules/anyname-0.2.tm | 63 ++ src/modules/flagfilter-0.3.tm | 10 +- src/modules/punk-0.1.tm | 57 +- src/modules/punk/du-999999.0a1.0.tm | 156 ++- src/modules/punk/mix-0.2.tm | 614 +++++++++++- .../mix/templates/layouts/project/README.md | 13 + .../src/bootsupport/{ => modules}/README.md | 0 .../templates/layouts/project/src/make.tcl | 85 ++ .../layouts/project/src/scriptapps/README.md | 40 +- .../project/src/scriptapps/wrappers/README.md | 99 ++ .../wrappers/sample_punk-multishell.cmd} | 0 .../wrappers/sample_punk-shellbat.bat} | 10 +- .../scriptappwrappers/punk-multishell.cmd | 270 +++++ .../scriptappwrappers/punk-shellbat.bat | 112 +++ src/modules/punk/timeinterval-999999.0a1.0.tm | 559 +++++++++++ .../punk/timeinterval-buildversion.txt | 3 + src/modules/punk/winpath-999999.0a1.0.tm | 16 +- src/modules/punkapp-0.1.tm | 38 +- src/modules/shellfilter-0.1.8.tm | 10 +- src/modules/shellthread-1.6.tm | 119 ++- src/modules/tcl9test-999999.0a1.0.tm | 72 ++ src/modules/tcl9test-buildversion.txt | 3 + src/modules/winlibreoffice-999999.0a1.0.tm | 246 +++++ src/modules/winlibreoffice-buildversion.txt | 3 + src/punk86.vfs/lib/app-punk/repl.tcl | 51 +- src/punk86.vfs/main.tcl | 8 +- src/scriptapps/tcltm | 902 +++++++++++++++++ src/scriptapps/wrappers/README.md | 93 ++ .../wrappers/sample_punk-multishell.cmd | 264 +++++ .../wrappers/sample_punk-shellbat.bat | 112 +++ src/vendormodules/cksum-1.1.4.tm | 200 ++++ src/vendormodules/natsort-0.1.1.5.tm | 8 +- 52 files changed, 6377 insertions(+), 1663 deletions(-) delete mode 100644 src/bootsupport/fileutil/decode-0.2.1.tm delete mode 100644 src/bootsupport/fileutil/multi-0.1.tm delete mode 100644 src/bootsupport/fileutil/multi/op-0.5.3.tm delete mode 100644 src/bootsupport/fileutil/paths-1.tm delete mode 100644 src/bootsupport/fileutil/traverse-0.6.tm create mode 100644 src/bootsupport/lib/README.md rename src/bootsupport/{ => modules}/README.md (100%) rename src/bootsupport/{ => modules}/cksum-1.1.4.tm (99%) create mode 100644 src/bootsupport/modules/cmdline-1.5.2.tm rename src/bootsupport/{ => modules}/fileutil-1.16.1.tm (99%) rename src/bootsupport/{ => modules}/punk/du-0.1.0.tm (96%) rename src/bootsupport/{ => modules}/punk/mix-0.2.tm (93%) rename src/bootsupport/{ => modules}/punk/repo-0.1.0.tm (100%) rename src/bootsupport/{ => modules}/punk/winpath-0.1.0.tm (100%) create mode 100644 src/bootsupport/modules/struct/set-2.2.3.tm create mode 100644 src/bootsupport/modules/struct/sets.tcl create mode 100644 src/bootsupport/modules/struct/sets_c.tcl create mode 100644 src/bootsupport/modules/struct/sets_tcl.tcl create mode 100644 src/build.cmd create mode 100644 src/modules/anyname-0.2.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/README.md rename src/modules/punk/mix/templates/layouts/project/src/bootsupport/{ => modules}/README.md (100%) create mode 100644 src/modules/punk/mix/templates/layouts/project/src/scriptapps/wrappers/README.md rename src/modules/punk/mix/templates/{utility/multishell.cmd => layouts/project/src/scriptapps/wrappers/sample_punk-multishell.cmd} (100%) rename src/modules/punk/mix/templates/{utility/shellbat.txt => layouts/project/src/scriptapps/wrappers/sample_punk-shellbat.bat} (95%) create mode 100644 src/modules/punk/mix/templates/utility/scriptappwrappers/punk-multishell.cmd create mode 100644 src/modules/punk/mix/templates/utility/scriptappwrappers/punk-shellbat.bat create mode 100644 src/modules/punk/timeinterval-999999.0a1.0.tm create mode 100644 src/modules/punk/timeinterval-buildversion.txt create mode 100644 src/modules/tcl9test-999999.0a1.0.tm create mode 100644 src/modules/tcl9test-buildversion.txt create mode 100644 src/modules/winlibreoffice-999999.0a1.0.tm create mode 100644 src/modules/winlibreoffice-buildversion.txt create mode 100644 src/scriptapps/tcltm create mode 100644 src/scriptapps/wrappers/README.md create mode 100644 src/scriptapps/wrappers/sample_punk-multishell.cmd create mode 100644 src/scriptapps/wrappers/sample_punk-shellbat.bat create mode 100644 src/vendormodules/cksum-1.1.4.tm diff --git a/src/bootsupport/fileutil/decode-0.2.1.tm b/src/bootsupport/fileutil/decode-0.2.1.tm deleted file mode 100644 index 02ce8a6a..00000000 --- a/src/bootsupport/fileutil/decode-0.2.1.tm +++ /dev/null @@ -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 diff --git a/src/bootsupport/fileutil/multi-0.1.tm b/src/bootsupport/fileutil/multi-0.1.tm deleted file mode 100644 index b95a728d..00000000 --- a/src/bootsupport/fileutil/multi-0.1.tm +++ /dev/null @@ -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 diff --git a/src/bootsupport/fileutil/multi/op-0.5.3.tm b/src/bootsupport/fileutil/multi/op-0.5.3.tm deleted file mode 100644 index 9d065198..00000000 --- a/src/bootsupport/fileutil/multi/op-0.5.3.tm +++ /dev/null @@ -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 diff --git a/src/bootsupport/fileutil/paths-1.tm b/src/bootsupport/fileutil/paths-1.tm deleted file mode 100644 index e387acf7..00000000 --- a/src/bootsupport/fileutil/paths-1.tm +++ /dev/null @@ -1,74 +0,0 @@ -# paths.tcl -- -# -# Manage lists of search paths. -# -# Copyright (c) 2009-2019 Andreas Kupries -# -# 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 diff --git a/src/bootsupport/fileutil/traverse-0.6.tm b/src/bootsupport/fileutil/traverse-0.6.tm deleted file mode 100644 index 2f36d109..00000000 --- a/src/bootsupport/fileutil/traverse-0.6.tm +++ /dev/null @@ -1,504 +0,0 @@ -# traverse.tcl -- -# -# Directory traversal. -# -# Copyright (c) 2006-2015 by Andreas Kupries -# -# 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 diff --git a/src/bootsupport/lib/README.md b/src/bootsupport/lib/README.md new file mode 100644 index 00000000..fd07419f --- /dev/null +++ b/src/bootsupport/lib/README.md @@ -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. diff --git a/src/bootsupport/README.md b/src/bootsupport/modules/README.md similarity index 100% rename from src/bootsupport/README.md rename to src/bootsupport/modules/README.md diff --git a/src/bootsupport/cksum-1.1.4.tm b/src/bootsupport/modules/cksum-1.1.4.tm similarity index 99% rename from src/bootsupport/cksum-1.1.4.tm rename to src/bootsupport/modules/cksum-1.1.4.tm index 6ff4e513..0fb17981 100644 --- a/src/bootsupport/cksum-1.1.4.tm +++ b/src/bootsupport/modules/cksum-1.1.4.tm @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ------------------------------------------------------------------------- -package require Tcl 8.2; # tcl minimum version +package require Tcl 8.5-; # tcl minimum version namespace eval ::crc { namespace export cksum diff --git a/src/bootsupport/modules/cmdline-1.5.2.tm b/src/bootsupport/modules/cmdline-1.5.2.tm new file mode 100644 index 00000000..4e5e1df9 --- /dev/null +++ b/src/bootsupport/modules/cmdline-1.5.2.tm @@ -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 . +# Copyright (c) 2003 by David N. Welton +# 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 +} diff --git a/src/bootsupport/fileutil-1.16.1.tm b/src/bootsupport/modules/fileutil-1.16.1.tm similarity index 99% rename from src/bootsupport/fileutil-1.16.1.tm rename to src/bootsupport/modules/fileutil-1.16.1.tm index cb9c6274..6d5c737e 100644 --- a/src/bootsupport/fileutil-1.16.1.tm +++ b/src/bootsupport/modules/fileutil-1.16.1.tm @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require Tcl 8.2 +package require Tcl 8.5- package require cmdline package provide fileutil 1.16.1 diff --git a/src/bootsupport/punk/du-0.1.0.tm b/src/bootsupport/modules/punk/du-0.1.0.tm similarity index 96% rename from src/bootsupport/punk/du-0.1.0.tm rename to src/bootsupport/modules/punk/du-0.1.0.tm index ad57193c..c908fa3f 100644 --- a/src/bootsupport/punk/du-0.1.0.tm +++ b/src/bootsupport/modules/punk/du-0.1.0.tm @@ -414,6 +414,45 @@ namespace eval punk::du { #caching this is faster than calling twapi api each time.. unknown if twapi is calculating from bitmask - or calling windows api #we could work out all flags and calculate from bitmask.. but it's not necessarily going to be faster than some simple caching mechanism like this + proc decode_win_attributes {bitmask} { + variable winfile_attributes + if {[dict exists $winfile_attributes $bitmask]} { + return [dict get $winfile_attributes $bitmask] + } else { + #list/dict shimmering? + return [lindex [lappend winfile_attributes $bitmask [twapi::decode_file_attributes $bitmask]] end] + } + } + proc attributes_twapi {path {detail basic}} { + try { + set iterator [twapi::find_file_open $path -detail $detail] ;# -detail full only adds data to the altname field + if {[twapi::find_file_next $iterator iteminfo]} { + set attrinfo [decode_win_attributes [dict get $iteminfo attrs]] + set result [dict create -archive 0 -hidden 0 -longname $path -readonly 0 -shortname {} -system 0] + if {"hidden" in $attrinfo} { + dict set result -hidden 1 + } + if {"system" in $attrinfo} { + dict set result -system 1 + } + if {"readonly" in $attrinfo} { + dict set result -readonly 1 + } + dict set result -shortname [dict get $iteminfo altname] + dict set result -rawflags $attrinfo + set extras [list] + foreach prop {ctime atime mtime size} { + lappend extras $prop [dict get $iteminfo $prop] + } + dict set result -extras $extras + return $result + } else { + error "could not read attributes for $path" + } + } finally { + catch {twapi::find_file_close $iterator} + } + } namespace export du_dirlisting_twapi du_dirlisting_generic du_dirlisting_unix # get listing without using unix-tools (may not be installed on the windows system) # this dirlisting is customised for du - so only retrieves dirs,files,filesizes (minimum work needed to perform du function) @@ -664,15 +703,6 @@ namespace eval punk::du { } - proc decode_win_attributes {bitmask} { - variable winfile_attributes - if {[dict exists $winfile_attributes $bitmask]} { - return [dict get $winfile_attributes $bitmask] - } else { - #list/dict shimmering? - return [lindex [lappend winfile_attributes $bitmask [twapi::decode_file_attributes $bitmask]] end] - } - } proc du_lit value { variable du_literal @@ -757,10 +787,10 @@ namespace eval punk::du { namespace eval ::punk::du::active { variable functions variable functions_kown - + upvar ::punk::du::has_twapi has_twapi if {"windows" eq $::tcl_platform(platform)} { - if {$punk::du::has_twapi} { + if {$has_twapi} { set_active_function du_dirlisting du_dirlisting_twapi } else { set_active_function du_dirlisting du_dirlisting_generic diff --git a/src/bootsupport/punk/mix-0.2.tm b/src/bootsupport/modules/punk/mix-0.2.tm similarity index 93% rename from src/bootsupport/punk/mix-0.2.tm rename to src/bootsupport/modules/punk/mix-0.2.tm index 57ad21f6..837f8690 100644 --- a/src/bootsupport/punk/mix-0.2.tm +++ b/src/bootsupport/modules/punk/mix-0.2.tm @@ -285,14 +285,16 @@ namespace eval punk::mix::cli { puts stdout "-done- project:$projectname projectdir: $projectdir" } interp alias {} ::punk::mix::cli::newproject {} ::punk::mix::cli::new - - proc visible_lib_glob {glob} { + + #search automatically wrapped in * * - can contain inner * ? globs + proc libsearch {searchstring} { + catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything if {[catch {package require natsort}]} { set has_natsort 0 } else { set has_natsort 1 } - set matches [lsearch -all -inline [package names] $glob] + set matches [lsearch -all -inline -nocase [package names] "*${searchstring}*"] set matchinfo [list] foreach m $matches { set versions [package versions $m] @@ -305,7 +307,47 @@ namespace eval punk::mix::cli { } return [join [lsort $matchinfo] \n] } - proc visible_lib_copy_to_modulefolder {library modulefoldername args} { + proc libinfo {libname} { + if {[catch {package require natsort}]} { + set has_natsort 0 + } else { + set has_natsort 1 + } + catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything + set pkgsknown [package names] + if {[set posn [lsearch $pkgsknown $libname]] >= 0} { + puts stdout "Found package [lindex $pkgsknown $posn]" + } else { + puts stderr "Package not found as available library/module - check tcl::tm::list and \$auto_path" + } + set versions [package versions [lindex $libname 0]] + if {$has_natsort} { + set versions [natsort::sort $versions] + } else { + set versions [lsort $versions] + } + if {![llength $versions]} { + puts stderr "No version numbers found for library/module $libname" + return false + } + puts stdout "Versions of $libname found: $versions" + set alphaposn [lsearch $versions "999999.*"] + if {$alphaposn >= 0} { + set alpha [lindex $versions $alphaposn] + #remove and tack onto beginning.. + set versions [lreplace $versions $alphaposn $alphaposn] + set versions [list $alpha {*}$versions] + } + foreach ver $versions { + set loadinfo [package ifneeded $libname $ver] + puts stdout "$libname $ver" + puts stdout "--- 'package ifneeded' script ---" + puts stdout $loadinfo + puts stdout "---" + } + return + } + proc libcopy_as_module {library modulefoldername args} { set defaults [list -askme 1] set opts [dict merge $defaults $args] set opt_askme [dict get $opts -askme] @@ -316,6 +358,8 @@ namespace eval punk::mix::cli { set has_natsort 1 } + catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything + if {[file pathtype $modulefoldername] eq "absolute"} { if {![file exists $modulefoldername]} { error "Path '$modulefoldername' not found. Enter a fully qualified path, or just the tail such as 'modules' if you are within the project to use /src/modules" @@ -350,7 +394,7 @@ namespace eval punk::mix::cli { } puts stdout "-----------------------------" - puts stdout "Using projectdir: $projectdir for visible_lib_copy_to_modulefolder" + puts stdout "Using projectdir: $projectdir for libcopy_as_module" puts stdout "-----------------------------" @@ -386,24 +430,73 @@ namespace eval punk::mix::cli { if {[llength $loadinfo] == 2 && [lindex $loadinfo 0] eq "source"} { set source_file [lindex $loadinfo 1] } elseif {[string match "*source*" $loadinfo]} { - set parts [split $loadinfo ";"] + set parts [list] + set loadinfo [string map [list \r\n \n] $loadinfo] + set lines [split $loadinfo \n] + foreach ln $lines { + lappend parts {*}[split $loadinfo ";"] + } set sources_found [list] + set loads_found [list] + set dependencies [list] + set incomplete_lines [list] foreach p $parts { + set p [string trim $p] + if {![string length $p]} { + continue ;#empty line or trailing colon + } + if {![info complete $p]} { + # + #probably a perfectly valid script - but slightly more complicated than we can handle + #better to defer to manual processing + lappend incomplete_lines $p + continue + } if {[lindex $p 0] eq "source"} { #may have args.. e.g -encoding utf-8 lappend sources_found [lindex $p end] } + if {[lindex $p 0] eq "load"} { + lappend loads_found [lrange $p 1 end] + } + if {[lrange $p 0 1] eq "package require"} { + lappend dependencies [lrange $p 2 end] + } + } + if {[llength $incomplete_lines]} { + puts stderr "unable to interpret load script for library $libfound" + puts stderr "Load info: $loadinfo" + return false + } + if {[llength $loads_found]} { + puts stderr "package $libfound appears to have binary components" + foreach l $loads_found { + puts stderr " binary - $l" + } + foreach s $sources_found { + puts stderr " script - $s" + } + puts stderr "Unable to automatically copy binary libraries to your module folder." + return false } if {[llength $sources_found] != 1} { puts stderr "sorry - unable to interpreet source library location" - puts stderr "Only 1 source supported for now: received $loadinfo" + puts stderr "Only 1 source supported for now" + puts stderr "Load info: $loadinfo" return false } + if {[llength $dependencies]} { + puts stderr "WARNING the package appears to depend on at least one other. Review and copy dependencies as required." + foreach d $dependencies { + puts stderr " - $d" + } + } + set source_file [lindex $sources_found 0] } else { puts stderr "sorry - unable to interpret source library location" - puts stderr "Found info: $loadinfo" + puts stderr "Load info: $loadinfo" return false } @@ -433,13 +526,17 @@ namespace eval punk::mix::cli { puts stdout "" puts stdout "Base module path: $modulefolder_path" puts stdout "Target path : $target_path" + puts stdout "results of 'package ifneeded $libfound'" + puts stdout "---" + puts stdout "$loadinfo" + puts stdout "---" puts stdout "Proceed to create ${pkgtail}-${ver}.tm module? Y|N" set stdin_state [fconfigure stdin] fconfigure stdin -blocking 1 set answer [string tolower [gets stdin]] fconfigure stdin -blocking [dict get $stdin_state -blocking] if {$answer ne "y"} { - puts stderr "mix visible_lib_copy_to_modulefolder aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." + puts stderr "mix libcopy_as_module aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." return } } @@ -462,7 +559,7 @@ namespace eval punk::mix::cli { set answer [string tolower [gets stdin]] fconfigure stdin -blocking [dict get $stdin_state -blocking] if {$answer ne "y"} { - puts stderr "mix visible_lib_copy_to_modulefolder aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." + puts stderr "mix libcopy_as_module aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." return } } @@ -785,6 +882,7 @@ namespace eval punk::mix::cli { set nsq [namespace qualifiers $modulename] return [string map [list :: /] $nsq] } + #find src/something folders which are not certain known folders with other purposes, (such as: bootsupport .vfs folders or vendor folders etc) and contain .tm file(s) proc find_source_module_paths {{path {}}} { if {![string length [set candidate [punk::repo::find_candidate $path]]]} { @@ -795,11 +893,16 @@ namespace eval punk::mix::cli { set antipatterns [list *.vfs vendor* lib _build doc embedded runtime bootsupport] set tm_folders [list] foreach sub $src_subs { + set is_ok 1 foreach anti $antipatterns { if {[string match $anti $sub]} { - continue + set is_ok 0 + break } } + if {!$is_ok} { + continue + } set testfolder [file join $candidate src $sub] set tmfiles [glob -nocomplain -dir $testfolder -type f -tail *.tm] if {[llength $tmfiles]} { diff --git a/src/bootsupport/punk/repo-0.1.0.tm b/src/bootsupport/modules/punk/repo-0.1.0.tm similarity index 100% rename from src/bootsupport/punk/repo-0.1.0.tm rename to src/bootsupport/modules/punk/repo-0.1.0.tm diff --git a/src/bootsupport/punk/winpath-0.1.0.tm b/src/bootsupport/modules/punk/winpath-0.1.0.tm similarity index 100% rename from src/bootsupport/punk/winpath-0.1.0.tm rename to src/bootsupport/modules/punk/winpath-0.1.0.tm diff --git a/src/bootsupport/modules/struct/set-2.2.3.tm b/src/bootsupport/modules/struct/set-2.2.3.tm new file mode 100644 index 00000000..2ed2c260 --- /dev/null +++ b/src/bootsupport/modules/struct/set-2.2.3.tm @@ -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 diff --git a/src/bootsupport/modules/struct/sets.tcl b/src/bootsupport/modules/struct/sets.tcl new file mode 100644 index 00000000..2ed2c260 --- /dev/null +++ b/src/bootsupport/modules/struct/sets.tcl @@ -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 diff --git a/src/bootsupport/modules/struct/sets_c.tcl b/src/bootsupport/modules/struct/sets_c.tcl new file mode 100644 index 00000000..c9837e94 --- /dev/null +++ b/src/bootsupport/modules/struct/sets_c.tcl @@ -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 + } + + # 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 diff --git a/src/bootsupport/modules/struct/sets_tcl.tcl b/src/bootsupport/modules/struct/sets_tcl.tcl new file mode 100644 index 00000000..ad76704f --- /dev/null +++ b/src/bootsupport/modules/struct/sets_tcl.tcl @@ -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 +} diff --git a/src/build.cmd b/src/build.cmd new file mode 100644 index 00000000..236f6ba3 --- /dev/null +++ b/src/build.cmd @@ -0,0 +1,275 @@ +set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershell;proc Hide s {proc $s args {}}; Hide :;rename set s2;Hide set;s2 1 list]"; set -- : "$@"; $1 = @' +: heredoc1 - hide from powershell (close sqote for unix shells) ' \ +: << 'HEREDOC1B_HIDE_FROM_BASH_AND_SH' +: .bat/.cmd launch section, leading colon hides from cmd, trailing slash hides next line from tcl \ +: "[Hide @ECHO; Hide ); Hide (;Hide echo]#not necessary but can help avoid errs in testing" +: Continuation char at end of this line and rem with curly-braces used to exlude Tcl from the whole cmd block \ +@REM { +@REM DO NOT MODIFY FIRST LINE OF THIS SCRIPT. shebang #! line is not required and will reduce functionality. +@REM Even comment lines can be part of the functionality of this script - modify with care. +@REM Change the value of nextshell in the next line if desired, and code within payload sections as appropriate. +@SET "nextshell=pwsh" +@REM nextshell set to pwsh,sh,bash or tclsh +@REM @ECHO nextshell is %nextshell% +@SET "validshells=pwsh,sh,bash,tclsh,tclkitsh,tclkit86bi" +@CALL SET keyRemoved=%%validshells:%nextshell%=%% +@REM Note that 'powershell' e.g v5 is just a fallback for when pwsh is not available +@REM ## ### ### ### ### ### ### ### ### ### ### ### ### ### +@REM -- cmd/batch file section (ignored on unix) +@REM -- This section intended only to launch the next shell +@REM -- Avoid customising this if possible. cmd/batch script is probably the least expressive language. +@REM -- custom windows payloads should be in powershell,tclsh or sh/bash code sections +@REM ## ### ### ### ### ### ### ### ### ### ### ### ### ### +@SETLOCAL EnableExtensions EnableDelayedExpansion +@SET "winpath=%~dp0" +@SET "fname=%~nx0" +@REM @ECHO fname %fname% +@REM @ECHO winpath %winpath% +@IF %nextshell%==pwsh ( + CALL pwsh -nop -c set-executionpolicy -Scope CurrentUser RemoteSigned + COPY "%~dp0%~n0.cmd" "%~dp0%~n0.ps1" >NUL + REM test availability of preferred option of powershell7+ pwsh + CALL pwsh -nop -nol -c write-host "statusmessage: pwsh-found" >NUL + SET pwshtest_exitcode=!errorlevel! + REM ECHO pwshtest_exitcode !pwshtest_exitcode! + IF !pwshtest_exitcode!==0 CALL pwsh -nop -nol "%~dp0%~n0.ps1" %* & SET task_exitcode=!errorlevel! + REM fallback to powershell if pwsh failed + IF NOT !pwshtest_exitcode!==0 ( + REM CALL powershell -nop -nol -c write-host powershell-found + CALL powershell -nop -nol -file "%~dp0%~n0.ps1" %* + SET task_exitcode=!errorlevel! + ) +) ELSE ( + IF %nextshell%==bash ( + CALL :getWslPath %winpath% wslpath + REM ECHO wslfullpath "!wslpath!%fname%" + CALL %nextshell% "!wslpath!%fname%" %* & SET task_exitcode=!errorlevel! + ) ELSE ( + REM probably tclsh or sh + IF NOT "x%keyRemoved%"=="x%validshells%" ( + REM sh uses /c/ instead of /mnt/c - at least if using msys. Todo, review what is the norm on windows with and without msys2,cygwin,wsl + REM and what logic if any may be needed. For now sh with /c/xxx seems to work the same as sh with c:/xxx + CALL %nextshell% "%~dp0%fname%" %* & SET task_exitcode=!errorlevel! + ) ELSE ( + ECHO %fname% has invalid nextshell value %nextshell% valid options are %validshells% + SET task_exitcode=66 + GOTO :exit + ) + ) +) +@GOTO :endlib +:getWslPath +@SETLOCAL + @SET "_path=%~p1" + @SET "name=%~nx1" + @SET "drive=%~d1" + @SET "rtrn=%~2" + @SET "result=/mnt/%drive:~0,1%%_path:\=/%%name%" +@ENDLOCAL & ( + @if "%~2" neq "" ( + SET "%rtrn%=%result%" + ) ELSE ( + ECHO %result% + ) +) +@GOTO :eof +:endlib + +: \ +@REM @SET taskexit_code=!errorlevel! & goto :exit +@GOTO :exit +# } +# rem call %nextshell% "%~dp0%~n0.cmd" %* +# -*- tcl -*- +# ## ### ### ### ### ### ### ### ### ### ### ### ### ### +# -- tcl script section +# -- This is a punk multishell file +# -- Primary payload target is Tcl, with sh,bash,powershell as helpers +# -- but it may equally be used with any of these being the primary script. +# -- It is tuned to run when called as a batch file, a tcl script a sh/bash script or a pwsh/powershell script +# -- i.e it is a polyglot file. +# -- The specific layout including some lines that appear just as comments is 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.polypunk.cmd in sh or bash +# -- e.g tclsh filename.cmd +# -- +# ## ### ### ### ### ### ### ### ### ### ### ### ### ### +rename set ""; rename s2 set; set k {-- "$@" "a}; if {[info exists ::env($k)]} {unset ::env($k)} ;# tidyup +Hide :exit;Hide {<#};Hide '@ +namespace eval ::punk::multishell { + set last_script_root [file dirname [file normalize ${argv0}/__]] + set last_script [file dirname [file normalize [info script]/__]] + if {[info exists argv0] && + $last_script eq $last_script_root + } { + set ::punk::multishell::is_main($last_script) 1 ;#run as executable/script - likely desirable to launch application and return an exitcode + } else { + set ::punk::multishell::is_main($last_script) 0 ;#sourced - likely to be being used as a library - no launch, no exit. Can use return. + } + if {"::punk::multishell::is_main" ni [info commands ::punk::multishell::is_main]} { + proc ::punk::multishell::is_main {{script_name {}}} { + if {$script_name eq ""} { + set script_name [file dirname [file normalize [info script]/--]] + } + return [set ::punk::multishell::is_main($script_name)] + } + } +} +# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl Payload +#puts "script : [info script]" +#puts "argcount : $::argc" +#puts "argvalues: $::argv" +#puts "argv0 : $::argv0" +# -- --- --- --- --- --- --- --- --- --- --- --- + + +# +# -*- tcl -*- \ +# 'build.tcl' name as required by kettle +# Can be run directly - but also using `pmix Kettle ...` or `pmix KettleShell ...` + + + +#exec ./kettle -f "$0" "${1+$@}" +kettle doc + + + +# + + + +# -- --- --- --- --- --- --- --- --- --- --- --- +# -- Best practice is to always return or exit above, or just by leaving the below defaults in place. +# -- If the multishell script is modified to have Tcl below the Tcl Payload section, +# -- then Tcl bracket balancing needs to be carefully managed in the shell and powershell sections below. +# -- Only the # in front of the two relevant if statements below needs to be removed to enable Tcl below +# -- but the sh/bash 'then' and 'fi' would also need to be uncommented. +# -- This facility left in place for experiments on whether configuration payloads etc can be appended +# -- to tail of file - possibly binary with ctrl-z char - but utility is dependent on which other interpreters/shells +# -- can be made to ignore/cope with such data. +if {[::punk::multishell::is_main]} { + exit 0 +} else { + return +} +# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl Payload +# end hide from unix shells \ +HEREDOC1B_HIDE_FROM_BASH_AND_SH +# sh/bash \ +shift && set -- "${@:1:$#-1}" +#------------------------------------------------------ +# -- This if block only needed if Tcl didn't exit or return above. +if false==false # else { + then + : +# ## ### ### ### ### ### ### ### ### ### ### ### ### ### +# -- sh/bash script section +# -- leave as is if all that is required is launching the Tcl payload" +# -- +# -- Note that sh/bash script isn't called when running a .bat/.cmd from cmd.exe on windows by default +# -- adjust @call line above ... to something like @call sh ... @call bash .. or @call env sh ... etc as appropriate +# -- if sh/bash scripting needs to run on windows too. +# -- +# ## ### ### ### ### ### ### ### ### ### ### ### ### ### +# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin sh Payload +#printf "start of bash or sh code" + +# +# + +# -- --- --- --- --- --- --- --- +# +exitcode=0 ;#default assumption +#-- sh/bash launches Tcl here instead of shebang line at top +#-- use exec to use exitcode (if any) directly from the tcl script +#exec /usr/bin/env tclsh "$0" "$@" +#-- alternative - can run sh/bash script after the tcl call. +/usr/bin/env tclsh "$0" "$@" +exitcode=$? +#echo "tcl exitcode: ${exitcode}" +#-- override exitcode example +#exit 66 +# +# -- --- --- --- --- --- --- --- + +# +# + + +#printf "sh/bash done \n" +# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end sh Payload +#------------------------------------------------------ +fi +exit ${exitcode} +# end hide sh/bash block from Tcl +# This comment with closing brace should stay in place whether if commented or not } +#------------------------------------------------------ +# begin hide powershell-block from Tcl - only needed if Tcl didn't exit or return above +if 0 { +: end heredoc1 - end hide from powershell \ +'@ +# ## ### ### ### ### ### ### ### ### ### ### ### ### ### +# -- powershell/pwsh section +# -- +# ## ### ### ### ### ### ### ### ### ### ### ### ### ### +function GetScriptName { $myInvocation.ScriptName } +$scriptname = getScriptName +# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin powershell Payload +#"Timestamp : {0,10:yyyy-MM-dd HH:mm:ss}" -f $(Get-Date) | write-host +#"Script Name : {0}" -f $scriptname | write-host +#"Powershell Version: {0}" -f $PSVersionTable.PSVersion.Major | write-host +#"powershell args : {0}" -f ($args -join ", ") | write-host +# -- --- --- --- + +# +# + + +# -- --- --- --- --- --- --- --- +# +tclsh $scriptname $args +# +# -- --- --- --- --- --- --- --- + + +# +# + +# unbal } + +# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end powershell Payload +#"powershell reporting exitcode: {0}" -f $LASTEXITCODE | write-host +Exit $LASTEXITCODE +# heredoc2 for powershell to ignore block below +$1 = @' +' +: end hide powershell-block from Tcl \ +# This comment with closing brace should stay in place whether 'if' commented or not } +: cmd exit label - return exitcode +:exit +: \ +@REM @ECHO exitcode: !task_exitcode! +: \ +@EXIT /B !task_exitcode! +# cmd has exited +: end heredoc2 \ +'@ +<# +# id:tailblock0 +# -- powershell multiline comment +#> +<# +# id:tailblock1 +# + +# +# -- unreachable by tcl directly if ctrl-z character is in the section above. (but file can be read and split on \x1A) +# -- Potential for zip and/or base64 contents, but we can't stop pwsh parser from slurping in the data +# -- so for example a plain text tar archive could cause problems depending on the content. +# -- final line in file must be the powershell multiline comment terminator or other data it can handle. +# -- e.g plain # comment lines will work too +# -- (for example a powershell digital signature is a # commented block of data at the end of the file) +#> + + diff --git a/src/make.tcl b/src/make.tcl index dbfbc427..90030508 100644 --- a/src/make.tcl +++ b/src/make.tcl @@ -25,20 +25,24 @@ if {"::try" ni [info commands ::try]} { #------------------------------------------------------------------------------ #Module loading from /src/bootsupport or src/*.vfs if script is within a .vfs folder #------------------------------------------------------------------------------ -#If the there is a folder directly under the current directory /src/bootsupport which contains .tm files when the starts +#If the there is a folder directly under the current directory /src/bootsupport/modules which contains .tm files when the starts # - then it will attempt to preference these modules # This allows a source update via 'fossil update' 'git pull' etc to pull in support modules for the make script +# and load these in preference to ones that may have been in the interps tcl::tm::list or auto_path due to environment variables set startdir [pwd] -set bootsupport [file join $startdir src bootsupport] -if {[file exists $bootsupport]} { +set bootsupport_mod [file join $startdir src bootsupport modules] +set bootsupport_lib [file join $startdir src bootsupport lib] +if {[file exists $bootsupport_mod] || [file exists $bootsupport_lib]} { set original_tm_list [tcl::tm::list] tcl::tm::remove {*}$original_tm_list + set original_auto_path $::auto_path + set ::auto_path [list $bootsupport_lib] - set support_modules [glob -nocomplain -dir $bootsupport -type f -tail *.tm] - set tcl_core_packages [list tcl::zlib zlib tcl::oo TclOO tcl::tommath tcl::zipfs tcl Tcl] - if {[llength $support_modules]} { - #only forget all *unloaded* package names if we are started in a .tm containing folder + set support_modules [glob -nocomplain -dir $bootsupport_mod -type f -tail *.tm] + set tcl_core_packages [list tcl::zlib zlib tcl::oo TclOO tcl::tommath tcl::zipfs Tcl Tk] ;#packages we + if {[llength $support_modules] || [llength [glob -nocomplain -dir $bootsupport_lib -tail *]]} { + #only forget all *unloaded* package names foreach pkg [package names] { if {$pkg in $tcl_core_packages} { continue @@ -47,11 +51,12 @@ if {[file exists $bootsupport]} { #puts stderr "Got no versions for pkg $pkg" continue } - if {[catch {package present $pkg}]} { + if {![string length [package provide $pkg]]} { + #no returned version indicates it wasn't loaded - so we can forget its index package forget $pkg } } - tcl::tm::add $bootsupport + tcl::tm::add $bootsupport_mod } @@ -86,13 +91,14 @@ if {[file exists $bootsupport]} { package require punk::repo - #restore module paths + #restore module paths and auto_path in addition to the bootsupport ones set tm_list_now [tcl::tm::list] foreach p $original_tm_list { if {$p ni $tm_list_now} { tcl::tm::add $p } } + set ::auto_path [list $bootsupport_lib {*}$original_auto_path] #------------------------------------------------------------------------------ } @@ -240,6 +246,12 @@ if {$::punkmake::command eq "get-project-info"} { exit 0 } +if {$::punkmake::command eq "shell"} { + package require pu + +} + + if {$::punkmake::command ne "project"} { puts stderr "Command $::punkmake::command not implemented - aborting." exit 1 diff --git a/src/modules/anyname-0.2.tm b/src/modules/anyname-0.2.tm new file mode 100644 index 00000000..2df5fd0a --- /dev/null +++ b/src/modules/anyname-0.2.tm @@ -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 -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 +# @@ 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" + + + + + # + # + + + + + + + + + + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + ## Ready + uplevel #0 [list package provide $pkg $version] +} +return + +#package provide tcl9test [namespace eval tcl9test { +# variable version +# set version 999999.0a1.0 +#}] +#return diff --git a/src/modules/flagfilter-0.3.tm b/src/modules/flagfilter-0.3.tm index 19bbfaf1..de713a35 100644 --- a/src/modules/flagfilter-0.3.tm +++ b/src/modules/flagfilter-0.3.tm @@ -2,7 +2,7 @@ #package provide [set ::pkg flagfilter-0.2.3] [namespace eval [lindex [split $pkg -] 0] {list [variable version [lindex [split $pkg -] 1][set ::pkg {}]]$version}] # #package provide [lindex [set pkg {flagfilter 0.2.3}] 0] [namespace eval [lindex $pkg 0] {list [variable version [lindex $pkg 1][set pkg {}]]$version}] -package provide [lassign {flagfilter 0.3} pkg ver]$pkg [namespace eval $pkg[set pkg {}] {list [variable version $ver[set ver {}]]$version}] +package provide [lassign {flagfilter 0.3} pkg ver]$pkg [namespace eval $pkg[set pkg {}] {list [variable version $::ver[set ::ver {}]]$version}] #Note: this is ugly.. particularly when trying to classify flags that are not fully specified i.e raw passthrough. # - we can't know if a flag -x --x etc is expecting a parameter or not. @@ -195,8 +195,12 @@ namespace eval flagfilter { #used as a basis for some object-instance names etc proc get_new_runid {} { variable run_counter - package require Thread - return "ff-[pid]-[thread::id]-[incr run_counter]" + if {[catch {package require Thread}]} { + set tid 0 + } else { + set tid [thread::id] + } + return "ff-[pid]-${tid}-[incr run_counter]" } namespace export check_flags diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index d692fa90..6c200fcd 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -1,9 +1,3 @@ -package provide punk [namespace eval punk { - #FUNCTL - variable version - set version 0.1 -}] - #Punk - where radical modification is a craft and anti-patterns are another exploratory tool for the Pattern Punk. #Built on Tcl of course - because it's the most powerful piece of under-appreciated and alternate-thinking engineering you can plug into. @@ -1050,6 +1044,7 @@ namespace eval punk { } set selector_script_complete 1 } elseif {[string is digit -strict [join $subindices ""]]} { + #review tip 551 (tcl9+?) #puts stderr ">>>>>>>>>>>>>>>> data: $leveldata selector: $selector subindices: $subindices" #pure numeric keylist - put straight to lindex # @@ -5142,6 +5137,10 @@ namespace eval punk { } + #tilde + interp alias {} ~ {} file join $::env(HOME) ;#HOME must be capitalized to work cross platform (lowercase home works on windows - but probably not elsewhere) + #interp alias {} ~ {} apply {args {file join $::env(HOME) $args}} + interp alias {} nsjoin {} punk::nsjoin interp alias {} nsprefix {} punk::nsprefix @@ -5730,9 +5729,9 @@ namespace eval punk { } } if {$in_vfs} { - set listing [punk::du::lib::du_dirlisting_tclvfs $location] + set listing [punk::du::lib::du_dirlisting_tclvfs $location $glob] } else { - set listing [punk::du::dirlisting $location] + set listing [punk::du::dirlisting $location $glob] } @@ -6904,14 +6903,28 @@ namespace eval punk { set text "" append text "Punk commands:\n" append text " help\n" - append text " pmix (ensemble command to make new projects/modules and to generate docs)\n" - append text " ./ view/change directory\n" - append text " ../ go up one directory \n" - append text " ./new make new directory and switch to it\n" - append text " :/ view/change namespace\n" - append text " :// view/change namespace (with command listing)\n" - append text " ::/ go up one namespace\n" - append text " :/new make child namespace and switch to it\n" + + #todo - load from source code annotation? + set cmdinfo [list] + lappend cmdinfo [list pmix "(ensemble command to make new projects/modules and to generate docs)"] + lappend cmdinfo [list ./ "view/change directory"] + lappend cmdinfo [list ../ "go up one directory"] + lappend cmdinfo [list ./new "make new directory and switch to it"] + lappend cmdinfo [list :/ "view/change namespace"] + lappend cmdinfo [list ::// "view/change namespace (with command listing)"] + lappend cmdinfo [list ::/ "go up one namespace"] + lappend cmdinfo [list :/new "make child namespace and switch to it"] + + set cmds [lsearch -all -inline -index 0 -subindices $cmdinfo *] + set descr [lsearch -all -inline -index 1 -subindices $cmdinfo *] + set widest1 [tcl::mathfunc::max {*}[lmap v $cmds {string length $v}]] + set widest2 [tcl::mathfunc::max {*}[lmap v $descr {string length $v}]] + set col1 "[string repeat " " $widest1] " + set col2 "[string repeat " " $widest2] " + foreach c $cmds d $descr { + append text " [overtype::left $col1 $c][overtype::left $col2 $d]" \n + } + lappend chunks [list stdout $text] @@ -7001,6 +7014,12 @@ namespace eval punk { } } + #pipeline-toys - put in lib/scriptlib? + ##geometric mean + #alias gmean .=> llength |> expr 1.0 / |e> .=i>* tcl::mathop::* |> .=>1,e>3 expr ** = 250} { @@ -537,6 +589,13 @@ namespace eval punk::du { #main classification if {"reparse_point" in $attrinfo} { + #this concept doesn't correspond 1-to-1 with unix links + #https://learn.microsoft.com/en-us/windows/win32/fileio/reparse-points + #review - and see which if any actually belong in the links key of our return + + + #One thing it could be, is a 'mounted folder' https://learn.microsoft.com/en-us/windows/win32/fileio/determining-whether-a-directory-is-a-volume-mount-point + # #we will treat as zero sized for du purposes.. review - option -L for symlinks like BSD du? #Note 'file readlink' can fail on windows - reporting 'invalid argument' - according to tcl docs, 'On systems that don't support symbolic links this option is undefined' #The link may be viewable ok in windows explorer, and cmd.exe /c dir and unix tools such as ls @@ -552,6 +611,7 @@ namespace eval punk::du { #Note also - a shortcut created in explorer with drag and drop to an existant folder is a different animal to a symlink (file with .lnk extension) even though it looks the same in explorer window. # #links are techically files too, whether they point to a file/dir or nothing. + lappend links $fullname } elseif {"directory" in $attrinfo} { if {$nm in {. ..}} { @@ -595,7 +655,7 @@ namespace eval punk::du { #this is the cross-platform pure-tcl version - which calls glob multiple times to make sure it gets everythign it needs and can ignore everything it needs to. #These repeated calls to glob will be a killer for performance - especially on a network share or when walking a large directory structure - proc du_dirlisting_generic {folderpath} { + proc du_dirlisting_generic {folderpath {glob *}} { #note platform differences between what is considered hidden make this tricky. # on windows 'glob .*' will not return some hidden dot items but will return . .. and glob -types hidden .* will not return some dotted items # glob -types hidden * on windows will not necessarily return all dot files/folders @@ -603,21 +663,35 @@ namespace eval punk::du { # we need to process * and .* in the same glob calls and remove duplicates # if we do * and .* in separate iterations of this loop we lose the ability to filter duplicates easily - #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink' - #set parent [lindex $folders $folderidx] - set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} * .*] - #set hdirs {} - set dirs [glob -nocomplain -dir $folderpath -types d * .*] + #note - with this design, we can't glob for all except dotfiles - this is for cross-platform consistency and efficiency (Review). + #dotfiles aren't considered hidden on all platforms + #some sort of antiglob is a possible enhancement + if {$glob eq "*"} { + #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink' + #set parent [lindex $folders $folderidx] + set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} * .*] + #set hdirs {} + set dirs [glob -nocomplain -dir $folderpath -types d * .*] + + set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} * .*] + #set hlinks {} + set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. struct::set difference will remove + #set links [lsort -unique [concat $hlinks $links[unset links]]] + + set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} * .*] + #set hfiles {} + set files [glob -nocomplain -dir $folderpath -types f * .*] + #set files {} + } else { + set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} $glob] + set dirs [glob -nocomplain -dir $folderpath -types d $glob] - set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} * .*] - #set hlinks {} - set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. struct::set difference will remove - #set links [lsort -unique [concat $hlinks $links[unset links]]] + set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} $glob] + set links [glob -nocomplain -dir $folderpath -types l $glob] ;#links may have dupes - we don't care. struct::set difference will remove - set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} * .*] - #set hfiles {} - set files [glob -nocomplain -dir $folderpath -types f * .*] - #set files {} + set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} $glob] + set files [glob -nocomplain -dir $folderpath -types f $glob] + } #note struct::set difference produces unordered result #struct::set difference removes duplicates @@ -640,21 +714,34 @@ namespace eval punk::du { } #we can halve the number of round trips on unix-like systems, where 'hidden' always corresponds to dotted files - proc du_dirlisting_unix {folderpath} { - set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs - set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove - set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files + proc du_dirlisting_unix {folderpath {glob *}} { + #yes - this is not consistent with standard way * works for unix folders - but it is consistent with behaviour of this facility on windows + if {$glob eq "*"} { + set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs + set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove + set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files + } else { + set dirs [glob -nocomplain -dir $folderpath -types d $glob] + set links [glob -nocomplain -dir $folderpath -types l $glob] + } #remove any links from our dirs and files collections set dirs [struct::set difference $dirs[unset dirs] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] set files [struct::set difference $files[unset files] $links] set vfsmounts [get_vfsmounts_in_folder $folderpath] + return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes {} flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {}] } - proc du_dirlisting_tclvfs {folderpath} { - set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs - #review - how are links handled in vfs? presumably if the vfs is a full implementation they should work at least within the vfs? - set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove - set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files + proc du_dirlisting_tclvfs {folderpath {glob *}} { + if {$glob eq "*"} { + set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs + #review - how are links handled in vfs? presumably if the vfs is a full implementation they should work at least within the vfs? + set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove + set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files + } else { + set dirs [glob -nocomplain -dir $folderpath -types d $glob] + set links [glob -nocomplain -dir $folderpath -types l $glob] + set files [glob -nocomplain -dir $folderpath -types f $glob] + } #remove any links from our dirs and files collections set dirs [struct::set difference $dirs[unset dirs] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] set files [struct::set difference $files[unset files] $links] @@ -664,15 +751,6 @@ namespace eval punk::du { } - proc decode_win_attributes {bitmask} { - variable winfile_attributes - if {[dict exists $winfile_attributes $bitmask]} { - return [dict get $winfile_attributes $bitmask] - } else { - #list/dict shimmering? - return [lindex [lappend winfile_attributes $bitmask [twapi::decode_file_attributes $bitmask]] end] - } - } proc du_lit value { variable du_literal @@ -757,10 +835,10 @@ namespace eval punk::du { namespace eval ::punk::du::active { variable functions variable functions_kown - + upvar ::punk::du::has_twapi has_twapi if {"windows" eq $::tcl_platform(platform)} { - if {$punk::du::has_twapi} { + if {$has_twapi} { set_active_function du_dirlisting du_dirlisting_twapi } else { set_active_function du_dirlisting du_dirlisting_generic diff --git a/src/modules/punk/mix-0.2.tm b/src/modules/punk/mix-0.2.tm index 57ad21f6..53101bee 100644 --- a/src/modules/punk/mix-0.2.tm +++ b/src/modules/punk/mix-0.2.tm @@ -285,14 +285,16 @@ namespace eval punk::mix::cli { puts stdout "-done- project:$projectname projectdir: $projectdir" } interp alias {} ::punk::mix::cli::newproject {} ::punk::mix::cli::new - - proc visible_lib_glob {glob} { + + #search automatically wrapped in * * - can contain inner * ? globs + proc libsearch {searchstring} { + catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything if {[catch {package require natsort}]} { set has_natsort 0 } else { set has_natsort 1 } - set matches [lsearch -all -inline [package names] $glob] + set matches [lsearch -all -inline -nocase [package names] "*${searchstring}*"] set matchinfo [list] foreach m $matches { set versions [package versions $m] @@ -305,7 +307,47 @@ namespace eval punk::mix::cli { } return [join [lsort $matchinfo] \n] } - proc visible_lib_copy_to_modulefolder {library modulefoldername args} { + proc libinfo {libname} { + if {[catch {package require natsort}]} { + set has_natsort 0 + } else { + set has_natsort 1 + } + catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything + set pkgsknown [package names] + if {[set posn [lsearch $pkgsknown $libname]] >= 0} { + puts stdout "Found package [lindex $pkgsknown $posn]" + } else { + puts stderr "Package not found as available library/module - check tcl::tm::list and \$auto_path" + } + set versions [package versions [lindex $libname 0]] + if {$has_natsort} { + set versions [natsort::sort $versions] + } else { + set versions [lsort $versions] + } + if {![llength $versions]} { + puts stderr "No version numbers found for library/module $libname" + return false + } + puts stdout "Versions of $libname found: $versions" + set alphaposn [lsearch $versions "999999.*"] + if {$alphaposn >= 0} { + set alpha [lindex $versions $alphaposn] + #remove and tack onto beginning.. + set versions [lreplace $versions $alphaposn $alphaposn] + set versions [list $alpha {*}$versions] + } + foreach ver $versions { + set loadinfo [package ifneeded $libname $ver] + puts stdout "$libname $ver" + puts stdout "--- 'package ifneeded' script ---" + puts stdout $loadinfo + puts stdout "---" + } + return + } + proc libcopy_as_module {library modulefoldername args} { set defaults [list -askme 1] set opts [dict merge $defaults $args] set opt_askme [dict get $opts -askme] @@ -316,6 +358,8 @@ namespace eval punk::mix::cli { set has_natsort 1 } + catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything + if {[file pathtype $modulefoldername] eq "absolute"} { if {![file exists $modulefoldername]} { error "Path '$modulefoldername' not found. Enter a fully qualified path, or just the tail such as 'modules' if you are within the project to use /src/modules" @@ -329,7 +373,7 @@ namespace eval punk::mix::cli { set pathinfo [punk::repo::find_roots_and_warnings_dict [pwd]] set projectdir [dict get $pathinfo closest] set modulefolders [lib::find_source_module_paths $projectdir] - foreach k [list modules bootsupport vendormodules] { + foreach k [list modules vendormodules] { set knownfolder [file join $projectdir src $k] if {$knownfolder ni $modulefolders} { lappend modulefolders $knownfolder @@ -339,18 +383,25 @@ namespace eval punk::mix::cli { foreach path $modulefolders { lappend mtails [file tail $path] } - if {$modulefoldername ni $mtails} { + + #special case bootsupport/modules so it can be referred to as just bootsupport or bootsupport/modules + lappend modulefolders [file join $projectdir src bootsupport/modules] + + if {$modulefoldername ni $mtails && $modulefoldername ni "bootsupport bootsupport/modules"} { set msg "Suplied modulefoldername '$modulefoldername' doesn't appear to be a known module folder within the project at $projectdir\n" append msg "Known module folders: [lsort $mtails]\n" append msg "Use a name from the above list, or a fully qualified path\n" error $msg } + if {$modulefoldername eq "bootsupport"} { + set modulefoldername "bootsupport/modules" + } set modulefolder_path [file join $projectdir src $modulefoldername] } puts stdout "-----------------------------" - puts stdout "Using projectdir: $projectdir for visible_lib_copy_to_modulefolder" + puts stdout "Using projectdir: $projectdir for libcopy_as_module" puts stdout "-----------------------------" @@ -383,39 +434,198 @@ namespace eval punk::mix::cli { } set loadinfo [package ifneeded $libfound $ver] - if {[llength $loadinfo] == 2 && [lindex $loadinfo 0] eq "source"} { + set loadinfo [string map [list \r\n \n] $loadinfo] + set loadinfo_lines [split $loadinfo \n] + if {[catch {llength $loadinfo}]} { + set loadinfo_is_listshaped 0 + } else { + set loadinfo_is_listshaped 1 + } + + #check for redirection to differently cased version of self - this is only detected if this is the only command in the package ifneeded result + #- must have matching version. REVIEW this requirement. Is there a legitimate reason to divert to a differently cased other-version? + set is_package_require_self_recased 0 + set is_package_require_diversion 0 + set lib_diversion_name "" + if {[llength $loadinfo_lines] == 1} { + #e.g Thread 3.0b1 diverts to thread 3.0b1 + set line1 [lindex $loadinfo_lines 0] + #check if multiparted with semicolon + #We need to distinguish "package require ; more stuff" from "package require ver> ;" possibly with trailing comment? + set parts [list] + if {[regexp {;} $line1]} { + foreach p [split $line1 {;}] { + set p [string trim $p] + if {[string length $p]} { + #only append parts with some content that doesn't look like a comment + if {![string match "#*" $p]} { + lappend parts $p + } + } + } + + } + if {[llength $parts] == 1} { + #seems like a lone package require statement. + #check if package require, package\trequire etc + if {[string match "package*require" [lrange $line1 0 1]]} { + set is_package_require_diversion 1 + if {[lindex $line1 2] eq "-exact"} { + #package require -exact + set lib_diversion_name [lindex $line1 3] + #check not an exact match - but is a -nocase match - i.e differs in case only + if {($lib_diversion_name ne $libfound) && [string match -nocase $lib_diversion_name $libfound]} { + if {[lindex $line1 4] eq $ver} { + set is_package_require_self_recased 1 + } + } + } else { + #may be package require + #or package require ??... + set lib_diversion_name [lindex $line1 2] + #check not an exact match - but is a -nocase match - i.e differs in case only + if {($lib_diversion_name ne $libfound) && [string match -nocase $lib_diversion_name $libfound]} { + set requiredversions [lrange $line1 3 end] + if {$ver in $requiredversions} { + set is_package_require_self_recased 1 + } + } + } + } + } + } + + if {$is_package_require_self_recased && [string length $lib_diversion_name]} { + #we only follow one level of package require redirection - seems unlikely/imprudent to follow arbitrarily in a while loop(?) + set libfound $lib_diversion_name + set loadinfo [package ifneeded $libfound $ver] + set loadinfo [string map [list \r\n \n] $loadinfo] + set loadinfo_lines [split $loadinfo \n] + if {[catch {llength $loadinfo}]} { + set loadinfo_is_listshaped 0 + } else { + set loadinfo_is_listshaped 1 + } + + + } else { + if {$is_package_require_diversion} { + #single + #for now - we'll abort and tell the user to run again with specified pkg/version + #We could automate - but it seems likely to be surprising. + puts stderr "Loadinfo for $libfound seems to be diverting to another pkg/version: $loadinfo_lines" + puts stderr "Review and consider trying with the pkg/version described in the result above." + return + } + } + + + if {$loadinfo_is_listshaped && ([llength $loadinfo] == 2 && [lindex $loadinfo 0] eq "source")} { set source_file [lindex $loadinfo 1] } elseif {[string match "*source*" $loadinfo]} { - set parts [split $loadinfo ";"] + set parts [list] + foreach ln $loadinfo_lines { + if {![string length $ln]} {continue} + lappend parts {*}[split $ln ";"] + } set sources_found [list] + set loads_found [list] + set dependencies [list] + set incomplete_lines [list] foreach p $parts { + set p [string trim $p] + if {![string length $p]} { + continue ;#empty line or trailing colon + } + if {[string match "*tclPkgSetup*" $p]} { + puts stderr "Unable to process load script for library $libfound" + puts stderr "The library appears to use the deprecated tcl library support utility 'tclPkgSetup'" + return false + } + if {![info complete $p]} { + # + #probably a perfectly valid script - but slightly more complicated than we can handle + #better to defer to manual processing + lappend incomplete_lines $p + continue + } if {[lindex $p 0] eq "source"} { #may have args.. e.g -encoding utf-8 lappend sources_found [lindex $p end] } + if {[lindex $p 0] eq "load"} { + lappend loads_found [lrange $p 1 end] + } + if {[lrange $p 0 1] eq "package require"} { + lappend dependencies [lrange $p 2 end] + } + } + if {[llength $incomplete_lines]} { + puts stderr "unable to interpret load script for library $libfound" + puts stderr "Load info: $loadinfo" + return false + } + if {[llength $loads_found]} { + puts stderr "package $libfound appears to have binary components" + foreach l $loads_found { + puts stderr " binary - $l" + } + foreach s $sources_found { + puts stderr " script - $s" + } + puts stderr "Unable to automatically copy binary libraries to your module folder." + return false } if {[llength $sources_found] != 1} { - puts stderr "sorry - unable to interpreet source library location" - puts stderr "Only 1 source supported for now: received $loadinfo" + puts stderr "sorry - unable to interpret source library location" + puts stderr "Only 1 source supported for now" + puts stderr "Load info: $loadinfo" return false } + if {[llength $dependencies]} { + #todo - check/ignore if dependency is Tcl ? + puts stderr "WARNING the package appears to depend on at least one other. Review and copy dependencies if required." + foreach d $dependencies { + puts stderr " - $d" + } + } + set source_file [lindex $sources_found 0] } else { puts stderr "sorry - unable to interpret source library location" - puts stderr "Found info: $loadinfo" + puts stderr "Load info: $loadinfo" return false } + #----------------------------------------- + #Analyse source file if {![file exists $source_file]} { error "Unable to verify source file existence at: $source_file" } set source_data [fcat $source_file -translation binary] - if {![string match "*package provide*" $source_data] || ![string match "*$libfound*" $source_data]} { - puts stderr "Sorry - unable to verify source file contains 'package provide' and '$libfound' - copy manually" + if {![string match "*package provide*" $source_data]} { + puts stderr "Sorry - unable to verify source file contains 'package provide' statement of some sort - copy manually" return false + } else { + if {![string match "*$libfound*" $source_data]} { + # as an exception - look for the specific 'package provide $pkg $version' as occurs in the auto-name auto-version modules + #e.g anyname-0.1.tm example + if {![string match "*package provide \$pkg \$version*" $source_data]} { + puts stderr "Sorry - unable to verify source file contains 'package provide' and '$libfound' - copy manually" + return false + } + } } + + if {[string match "*lappend ::auto_path*" $source_data] || [string match "*lappend auto_path*" $source_data] || [string match "*set ::auto_path*" $source_data]} { + puts stderr "Sorry - '$libfound' source file '$source_file' appears to rely on ::auto_path and can't be automatically copied as a .tm module" + puts stderr "Copy the library across to a lib folder instead" + return false + } + #----------------------------------------- + set moduleprefix [punk::nsprefix $libfound] if {[string length $moduleprefix]} { set moduleprefix_parts [punk::nsparts $moduleprefix] @@ -433,13 +643,17 @@ namespace eval punk::mix::cli { puts stdout "" puts stdout "Base module path: $modulefolder_path" puts stdout "Target path : $target_path" + puts stdout "results of 'package ifneeded $libfound'" + puts stdout "---" + puts stdout "$loadinfo" + puts stdout "---" puts stdout "Proceed to create ${pkgtail}-${ver}.tm module? Y|N" set stdin_state [fconfigure stdin] fconfigure stdin -blocking 1 set answer [string tolower [gets stdin]] fconfigure stdin -blocking [dict get $stdin_state -blocking] if {$answer ne "y"} { - puts stderr "mix visible_lib_copy_to_modulefolder aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." + puts stderr "mix libcopy_as_module aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." return } } @@ -462,7 +676,7 @@ namespace eval punk::mix::cli { set answer [string tolower [gets stdin]] fconfigure stdin -blocking [dict get $stdin_state -blocking] if {$answer ne "y"} { - puts stderr "mix visible_lib_copy_to_modulefolder aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." + puts stderr "mix libcopy_as_module aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." return } } @@ -472,39 +686,179 @@ namespace eval punk::mix::cli { return $target_path } + proc wrap_templates {} { + set libwrapper_folder_default [file join [lib::mix_templates_dir] utility scriptappwrappers] + set wrapper_template $libwrapper_folder_default/punk-multishell.cmd - proc wrap_in_multishell {filepath args} { - set defaults [list -askme 1] - set opts [dict merge $defaults $args] + } + #specific filepath to just wrap one script at the tcl-payload or xxx-payload-pre-tcl site + #scriptset name to substiture multiple scriptset.xxx files at the default locations - or as specified in scriptset.wrapconf + proc wrap_in_multishell {filepath_or_scriptset args} { + set defaults [list -askme 1 -template \uFFFF] + set opts [dict merge $defaults $args] + set opt_askme [dict get $opts -askme] + set opt_template [dict get $opts -template] + set ext [file extension $filepath_or_scriptset] + set startdir [pwd] + + set usage "" + append usage "Use directly with the script file to wrap, or supply the name of a scriptset" \n + append usage "The scriptset name will be used to search for yourname.sh|tcl|ps1 or names as you specify in yourname.wrapconfig if it exists" \n + append usage "If no template is specified in a .wrapconfig and no -template argument is supplied, it will default to punk-multishell.cmd" \n + if {![string length $filepath_or_scriptset]} { + puts stderr "No filepath_or_scriptset specified" + puts stderr $usage + return false + } - set opt_askme [dict get $opts -askme] - if {[file type $filepath] ne "file"} { - error "wrap_in_multishell: only script files can be wrapped." + #first check if relative or absolute path matches a file + if {[file pathtype $filepath_or_scriptset] eq "absolute"} { + set specified_path $filepath_or_scriptset + } else { + set specified_path [file join $startdir $filepath_or_scriptset] } - set ext [string trim [file extension $filepath] .] - #set allowed_extensions [list tcl ps1 sh bash] - #TODO - set allowed_extensions [list tcl] - if {[string tolower $ext] ni $allowed_extensions} { - error "wrap_in_multishell: script must have file extension in list: $allowed_extensions" + + set ext [string trim [file extension $filepath_or_scriptset] .] + set allowed_extensions [list wrapconfig tcl ps1 sh bash] + #set allowed_extensions [list tcl] + set found_script 0 + if {[file exists $specified_path]} { + set found_script 1 + } else { + foreach e $allowed_extensions { + if {[file exists $filepath_or_scriptset.$e]} { + set found_script 1 + break + } + } } - set output_file [file rootname $filepath].cmd - if {[file exists $output_file]} { - error "wrap_in_multishell: target file $output_file already exists.. aborting" + set scriptset [file rootname [file tail $specified_path]] + if {$found_script} { + if {[file type $specified_path] eq "file"} { + set specified_root [file dirname $specified_path] + set pathinfo [punk::repo::find_roots_and_warnings_dict [file dirname $specified_path]] + set projectroot [dict get $pathinfo closest] + if {[string length $projectroot]} { + #use the specified files folder - but use the main scriptapps/wrappers folder if specified one has no wrappers subfolder + set scriptroot [file dirname $specified_path] + if {[file exists $scriptroot/wrappers]} { + set customwrapper_folder $scriptroot/wrappers + } else { + set customwrapper_folder $projectroot/src/scriptapps/wrappers + } + } else { + #outside of any project + set scriptroot [file dirname $specified_path] + if {[file exists $scriptroot/wrappers]} { + set customwrapper_folder $scriptroot/wrappers + } else { + #no customwrapper folder available + set customwrapper_folder "" + } + } + } else { + puts stderr "wrap_in_multishell doesn't currently support a directory as the path." + puts stderr $usage + return false + } + } else { + set pathinfo [punk::repo::find_roots_and_warnings_dict $startdir] + set projectroot [dict get $pathinfo closest] + if {[string length $projectroot]} { + if {[llength [file split $filepath_or_scriptset]] > 1} { + puts stderr "filepath_or_scriptset looks like a path - but doesn't seem to point to a file" + puts stderr "Ensure you are within a project and use just the name of the scriptset, or pass in the full correct path or relative path to current directory" + puts stderr $usage + return false + } else { + #we've already ruled out empty string - so must have a single element representing scriptset - possibly with file extension + set scriptroot $projectroot/src/scriptapps + set customwrapper_folder $projectroot/src/scriptapps/wrappers + #check something matches the scriptset.. + set something_found "" + if {[file exists $scriptroot/$scriptset]} { + set found_script 1 + set something_found $scriptroot/$scriptset ;#extensionless file - that's ok too + } else { + foreach e $allowed_extensions { + if {[file exists $scriptroot/$scriptset.$e]} { + set found_script 1 + set something_found $scriptroot/$scriptset.$e + break + } + } + } + if {!$found_script} { + puts stderr "Searched within $scriptroot" + puts stderr "Unable to find a file matching $scriptset or one of the extensions: $allowed_extensions" + puts stderr $usage + return false + } else { + if {[file pathtype $something_found] ne "file"} { + puts stderr "wrap_in_multishell doesn't currently support a directory as the path." + puts stderr $usage + return false + } + } + } + + } else { + puts stderr "filepath_or_scriptset parameter doesn't seem to refer to a file, and you are not within a directory where projectroot and src/scriptapps/wrappers can be determined" + puts stderr $usage + return false + } } + #assert - customwrapper_folder var exists - but might be empty + + if {[string length $ext]} { + #If there was an explicitly supplied extension - then that file should exist + if {![file exists $scriptroot/$scriptset.$ext]} { + puts stderr "Explicit extension .$ext was supplied - but matching file not found." + puts stderr $usage + return false + } else { + if {$ext eq "wrapconfig"} { + set process_extensions ALLFOUNDORCONFIGURED + } else { + set process_extensions $ext + } + } + } else { + #no explicit extension - process all for scriptset + set process_extensions ALLFOUNDORCONFIGURED + } + #process_extensions - either a single one - or all found or as per .wrapconfig - set startdir [pwd] - set workroot [punk::repo::find_candidate $startdir] - set wrapper_template $workroot/src/ - set tpldir [lib::mix_templates_dir] - set wrapper_template $tpldir/utility/multishell.cmd + + set libwrapper_folder_default [file join [lib::mix_templates_dir] utility scriptappwrappers] + if {$opt_template eq "\uFFFF"} { + set templatename punk-multishell.cmd + } + if {[string length $customwrapper_folder] && [file exists [file join $customwrapper_folder $templatename] ]} { + set wrapper_template [file join $customwrapper_folder $templatename] + } else { + set wrapper_template [file join $libwrapper_folder_default $templatename] + } + if {![file exists $wrapper_template]} { error "wrap_in_multishell: unable to find multishell template at $wrapper_template" } + + + #todo + #output_file extension depends on the template being used.. + + + set output_file $scriptset.cmd + if {[file exists $output_file]} { + error "wrap_in_multishell: target file $output_file already exists.. aborting" + } + + set fdt [open $wrapper_template r] fconfigure $fdt -translation binary set template_data [read $fdt] @@ -520,6 +874,21 @@ namespace eval punk::mix::cli { #foreach ln $template_lines { #} + set list_input_files [list] + if {$process_extensions eq "ALLFOUNDORCONFIGURED"} { + #todo - look for .wrapconfig or all extensions for the scriptset + puts stderr "Sorry - only single input file supported - implementation incomplete" + return false + } else { + lappend list_input_files $scriptroot/$scriptset.$ext + } + + #todo - split template at each etc marker and build a dict of parts + + + #hack - process one input + set filepath [lindex $list_input_files 0] + set fdscript [open $filepath r] fconfigure $fdscript -translation binary set script_data [read $fdscript] @@ -710,11 +1079,20 @@ namespace eval punk::mix::cli { #review - why can't we be anywhere in the project? if {([file tail $sourcefolder] ne "src") || (![file exists $sourcefolder/make.tcl])} { - puts stderr "mix make must be run from src folder containing make.tcl - unable to proceed (cwd: [pwd])" + puts stderr "pmix make must be run from src folder containing make.tcl - unable to proceed (cwd: [pwd])" if {[string length $project_base]} { - if {[file exists $project_base/src] && [string tolower [pwd]] ne [string tolower $projectbase/src]} { + if {[file exists $project_base/src] && [string tolower [pwd]] ne [string tolower $project_base/src]} { puts stderr "Try cd to $project_base/src" } + } else { + if {[file exists $startdir/Makefile]} { + puts stdout "A Makefile exists at $startdir/Makefile." + if {"windows" eq $::tcl_platform(platform)} { + puts stdout "Try running: msys2 -ucrt64 -here -c \"make build\" or bash -c \"make build\"" + } else { + puts stdout "Try runing: make build" + } + } } return false } @@ -766,16 +1144,154 @@ namespace eval punk::mix::cli { tailcall lib::kettle_call shell {*}$args } - #proc libexample {} { - # set result [lib::libfunc1 test] - # return $result - #} namespace eval lib { - proc libfunc1 {args} { - return libfunc1-$args + proc _scriptapp_tag_from_line {line} { + set result [list istag 0 raw ""] ;#default assumption. All + #---- + set startc [string first "#" $line] ;#tags must be commented + #todo - review. next line is valid - note # doesn't have to be the only one before + # @REM # etc < blah # etc + #--- + #fix - we should use a regexp on at least and only catch tagname without whitespace + regexp {(\s*).*} $line _ln indent ;#will match on empty line, whitespace only line - or anything really. + set indent [string map [list \t " "] $indent] ;#opinionated I guess - but need to normalize to something. The spec is that spaces should be used anyway. + dict set result indent [string length $indent] + set starttag [string first "<" $line] + set pretag [string range $line $startc $starttag-1] + if {[string match "*>*" $pretag]} { + return [list istag 0 raw $line reason pretag_contents] + } + set closetag [string first ">" $line] + set inelement [string range $line $starttag+1 $closetag-1] + if {[string match "*<*" $inelement]} { + return [list istag 0 raw $line reason tag_malformed_angles] + } + set elementchars [split $inelement ""] + set numslashes [llength [lsearch -all $elementchars "/"]] + if {$numslashes == 0} { + dict set result type "open" + } elseif {$numslashes == 1} { + if {[lindex $elementchars 0] eq "/"} { + dict set result type "close" + } elseif {[lindex $elementchars end] eq "/"} { + dict set result type "openclose" + } else { + return [list istag 0 raw $line reason tag_malformed_slashes] + } + } else { + return [list istag 0 raw $line reason tag_malformed_extraslashes] + } + if {[dict get $result type] eq "open"} { + dict set result name $inelement + } elseif {[dict get $result type] eq "close"} { + dict set result name [string range $inelement 1 end] + } else { + dict set result name [string range $inelement 0 end-1] + } + dict set result istag 1 + dict set result raw $line + return $result } + + #get all \n#\n ...\n# data - where number of intervening newlines is at least one (and whitespace and/or other data can precede #) + #we don't verify 'something' against known tags - as custom templates can have own tags + #An openclose tag # is used to substitute a specific line in its entirety - but the tag *must* remain in the line + # + #e.g for the line: + # @set "nextshell=pwsh" & :: # + #The .wrapconfig might contain + # tag line {@set "nextshell=tclsh" & :: @} + # + proc scriptapp_wrapper_get_tags {wrapperdata} { + set wrapperdata [string map [list \r\n \n] $wrapperdata] + set lines [split $wrapperdata \n] + #set tags_in_data [dict create];#active tags - list of lines accumulating. supports nested tags + set status 0 + set tags [dict create] + set errors [list] + set errortags [dict create] ;#mark names invalid on first error so that more than 2 tags can't obscure config problem + set linenum 1 ;#editors and other utils use 1-based indexing when referencing files - we should too to avoid confusion, despite it being less natural for lindex operations on the result. + foreach ln $lines { + set lntrim [string trim $ln] + if {![string length $lntrim]} { + incr linenum + continue + } + if {[string match "*#*<*>*" $lntrim]} { + set taginfo [_scriptapp_tag_from_line $ln] ;#use untrimmed line - to get indent + if {[dict get $taginfo istag]} { + set nm [dict get $taginfo name] + if {[dict exists $errortags $nm]} { + #tag is already in error condition - + } else { + set tp [dict get $taginfo type] ;# type singular - related to just one line + #set raw [dict get $taginfo raw] #equivalent to $ln + if {[dict exists $tags $nm]} { + #already seen tag name + #tags dict has types key *plural* - need to track whether we have type open and type close (or openclose for self-closing tags) + if {[dict get $tags $nm types] ne "open"} { + lappend errors "line: $linenum tag $nm encountered type $tp after existing type [dict get $tags $nm types]" + dict incr errortags $nm + } else { + #we already have open - expect only close + if {$tp ne "close"} { + lappend errors "line: $linenum tag $nm encountered type $tp after existing type [dict get $tags $nm types]" + dict incr errortags $nm + } else { + #close after open + dict set tags $nm types [list open close] + dict set tags $nm end $linenum + set taglines [dict get $tags $nm taglines] + if {[llength $taglines] != 1} { + error "Unexpected result when closing tag $nm. Existing taglines length not 1." + } + dict set tags $nm taglines [concat $taglines $ln] + } + } + } else { + #first seen of tag name + if {$tp eq "close"} { + lappend errors "line: $linenum tag $nm encountered type $p close first" + dict incr errortags $nm + } else { + dict set tags $nm types $tp + dict set tags $nm indent [dict get $taginfo indent] + if {$tp eq "open"} { + dict set tags $nm start $linenum + dict set tags $nm taglines [list $ln] ;#first entry - another will be added on encountering matching closing tag + } elseif {$tp eq "openclose"} { + dict set tags $nm start $linenum + dict set tags $nm end $linenum + dict set tags $nm taglines [list $ln] ;#single entry is final result for self-closing tag + } + } + } + } + } else { + #looks like it should be a tag.. but failed to even parse for some reason.. just add to errorlist + lappend errors "line: $linenum tag parse failure reason: [dict get $taginfo reason] raw line: [dict get $taginfo raw]" + } + } + #whether the line is tag or not append to any tags_in_data + #foreach t [dict keys $tags_in_data] { + # dict lappend tags_in_data $t $ln ;#accumulate raw lines - written to the tag entry in tags only on encountering a closing tag, then removed from tags_in_data + #} + incr linenum + } + #assert [expr {$linenum -1 == [llength $lines]}] + if {[llength $errors]} { + set status 0 + } else { + set status 1 + } + if {$linenum == 0} { + + } + return [dict create ok $status linecount [llength $lines] data $tags errors $errors] + } + proc module_types {} { #first in list is default for unspecified -type when creating new module return [list plain tarjar zipkit] @@ -785,6 +1301,7 @@ namespace eval punk::mix::cli { set nsq [namespace qualifiers $modulename] return [string map [list :: /] $nsq] } + #find src/something folders which are not certain known folders with other purposes, (such as: bootsupport .vfs folders or vendor folders etc) and contain .tm file(s) proc find_source_module_paths {{path {}}} { if {![string length [set candidate [punk::repo::find_candidate $path]]]} { @@ -795,11 +1312,16 @@ namespace eval punk::mix::cli { set antipatterns [list *.vfs vendor* lib _build doc embedded runtime bootsupport] set tm_folders [list] foreach sub $src_subs { + set is_ok 1 foreach anti $antipatterns { if {[string match $anti $sub]} { - continue + set is_ok 0 + break } } + if {!$is_ok} { + continue + } set testfolder [file join $candidate src $sub] set tmfiles [glob -nocomplain -dir $testfolder -type f -tail *.tm] if {[llength $tmfiles]} { @@ -961,7 +1483,7 @@ namespace eval punk::mix::cli { } proc copy_nonmodules_from_source_to_base {srcdir basedir args} { #set keys [dict keys $args] - set defaults [list -glob * -antiglob_file [list "*.tm" "*-buildversion.txt"]] + set defaults [list -glob * -antiglob_file [list "*.tm" "*-buildversion.txt" "*.exe"]] set opts [dict merge $defaults $args] copy_files_from_source_to_target $srcdir $basedir {*}$opts } diff --git a/src/modules/punk/mix/templates/layouts/project/README.md b/src/modules/punk/mix/templates/layouts/project/README.md new file mode 100644 index 00000000..841c3dd3 --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/README.md @@ -0,0 +1,13 @@ +%project% +============================== + ++ ++ + + +About +------------------------------ + ++ ++ ++ diff --git a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/README.md b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/README.md similarity index 100% rename from src/modules/punk/mix/templates/layouts/project/src/bootsupport/README.md rename to src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/README.md diff --git a/src/modules/punk/mix/templates/layouts/project/src/make.tcl b/src/modules/punk/mix/templates/layouts/project/src/make.tcl index 70b41b1b..6ef2f1dc 100644 --- a/src/modules/punk/mix/templates/layouts/project/src/make.tcl +++ b/src/modules/punk/mix/templates/layouts/project/src/make.tcl @@ -21,6 +21,87 @@ if {"::try" ni [info commands ::try]} { puts stderr "Tcl interpreter possibly too old - 'try' command not found - aborting" exit 1 } + +#------------------------------------------------------------------------------ +#Module loading from /src/bootsupport or src/*.vfs if script is within a .vfs folder +#------------------------------------------------------------------------------ +#If the there is a folder directly under the current directory /src/bootsupport/modules which contains .tm files when the starts +# - then it will attempt to preference these modules +# This allows a source update via 'fossil update' 'git pull' etc to pull in support modules for the make script +# and load these in preference to ones that may have been in the interps tcl::tm::list or auto_path due to environment variables +set startdir [pwd] +set bootsupport_mod [file join $startdir src bootsupport modules] +set bootsupport_lib [file join $startdir src bootsupport lib] +if {[file exists $bootsupport_mod] || [file exists $bootsupport_lib]} { + + set original_tm_list [tcl::tm::list] + tcl::tm::remove {*}$original_tm_list + set original_auto_path $::auto_path + set ::auto_path [list $bootsupport_lib] + + set support_modules [glob -nocomplain -dir $bootsupport_mod -type f -tail *.tm] + set tcl_core_packages [list tcl::zlib zlib tcl::oo TclOO tcl::tommath tcl::zipfs tcl Tcl] + if {[llength $support_modules] || [llength [glob -nocomplain -dir $bootsupport_lib -tail *]]} { + #only forget all *unloaded* package names + foreach pkg [package names] { + if {$pkg in $tcl_core_packages} { + continue + } + if {![llength [package versions $pkg]]} { + #puts stderr "Got no versions for pkg $pkg" + continue + } + if {[catch {package present $pkg}]} { + #error indicates it wasn't loaded - so we can forget its index + package forget $pkg + } + } + tcl::tm::add $bootsupport_mod + } + + + #todo - review usecase + if {[string match "*.vfs/*" [info script]]} { + #src/xxx.vfs/lib/app-punk/repl.tcl + #we assume if calling directly into .vfs that the user would prefer to use src/modules - so go up 4 levels + set modulefolder [file dirname [file dirname [file dirname [file dirname [info script]]]]]/modules + + } else { + # .../bin/punkXX.exe look for ../modules (i.e modules folder at same level as bin folder) + set modulefolder [file dirname [file dirname [info nameofexecutable]]]/modules + } + + if {[file exists $modulefolder]} { + tcl::tm::add $modulefolder + } else { + puts stderr "Warning unable to find module folder at: $modulefolder" + } + if {[file exists [pwd]/modules]} { + tcl::tm::add [pwd]/modules + } + + #package require Thread + #These are strong dependencies + # - the repl requires Threading and punk,shellfilter,shellrun to call and display properly. + # tm list already indexed - need 'package forget' to find modules based on current tcl::tm::list + + package forget punk::mix + package require punk::mix + package forget punk::repo + package require punk::repo + + + #restore module paths and auto_path in addition to the bootsupport ones + set tm_list_now [tcl::tm::list] + foreach p $original_tm_list { + if {$p ni $tm_list_now} { + tcl::tm::add $p + } + } + set ::auto_path [list $bootsupport_lib {*}$original_auto_path] + #------------------------------------------------------------------------------ +} + # ** *** *** *** *** *** *** *** *** *** *** *** #*temporarily* hijack package command # ** *** *** *** *** *** *** *** *** *** *** *** @@ -147,15 +228,19 @@ if {$::punkmake::command eq "get-project-info"} { if {[punk::repo::find_fossil $scriptfolder] eq $projectroot} { set vc "fossil" set rev [punk::repo::fossil_revision $scriptfolder] + set rem [punk::repo::fossil_remote $scriptfolder] } elseif {[punk::repo::find_git $scriptfolder] eq $projectroot} { set vc "git" set rev [punk::repo::git_revision $scriptfolder] + set rem [punk::repo::git_remote $scriptfolder] } else { set vc " - none found -" set rev "n/a" + set remotes "n/a" } puts stdout "- version control : $vc" puts stdout "- revision : $rev" + puts stdout "- remote : $rem" puts stdout "- -- --- --- --- --- --- --- --- --- ---" exit 0 diff --git a/src/modules/punk/mix/templates/layouts/project/src/scriptapps/README.md b/src/modules/punk/mix/templates/layouts/project/src/scriptapps/README.md index 76e5030b..a3027744 100644 --- a/src/modules/punk/mix/templates/layouts/project/src/scriptapps/README.md +++ b/src/modules/punk/mix/templates/layouts/project/src/scriptapps/README.md @@ -1,20 +1,20 @@ -Create multishell scripts from your .tcl .sh and .ps1 scripts that are stored here. - -Use the pmix wrap functions to generate a multishell .cmd file from your scripts. -This .cmd is a 'polyglot' script - it should run when called from any of the target interpreters. - - -A multishell .cmd file is a cross-platform script that can easily be run on Windows and unix-like platforms. - -The .cmd extension is primarily a convenience so that it can be run easily by name on windows but it is ok to either leave it as that on other platforms, or rename it appropriately. - -On unix-like platforms it can be called with a bourne shell such as sh or bash. - -On windows, it can also be called with sh or bash if they are available - but the usual method would be to run it under cmd.exe initially just by opening a cmd prompt and running it. -This will run some windows batch script to automatically generate a corresponding .ps1 file and execution will switch to powershell 5 or powershell 7 (pwsh) if available. -Subsequently the command can be run directly from powershell. - -Whether called from Bourne shell, or cmd.exe or powershell - the usual payload would be your wrapped Tcl code - but it's also possible for powershell or sh/bash to be the primary payload script. -Any of these languages could easily be used to detect and launch other scripts/utilities that you may distribute with your app. - - +Create multishell scripts from your .tcl .sh and .ps1 scripts that are stored here. + +Use the pmix wrap functions to generate a multishell .cmd file from your scripts. +This .cmd is a 'polyglot' script - it should run when called from any of the target interpreters. + + +A multishell .cmd file is a cross-platform script that can easily be run on Windows and unix-like platforms. + +The .cmd extension is primarily a convenience so that it can be run easily by name on windows but it is ok to either leave it as that on other platforms, or rename it appropriately. + +On unix-like platforms it can be called with a bourne shell such as sh or bash. + +On windows, it can also be called with sh or bash if they are available - but the usual method would be to run it under cmd.exe initially just by opening a cmd prompt and running it. +This will run some windows batch script to automatically generate a corresponding .ps1 file and execution will switch to powershell 5 or powershell 7 (pwsh) if available. +Subsequently the command can be run directly from powershell. + +Whether called from Bourne shell, or cmd.exe or powershell - the usual payload would be your wrapped Tcl code - but it's also possible for powershell or sh/bash to be the primary payload script. +Any of these languages could easily be used to detect and launch other scripts/utilities that you may distribute with your app. + + diff --git a/src/modules/punk/mix/templates/layouts/project/src/scriptapps/wrappers/README.md b/src/modules/punk/mix/templates/layouts/project/src/scriptapps/wrappers/README.md new file mode 100644 index 00000000..05bfdd08 --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/scriptapps/wrappers/README.md @@ -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 +# +# + +yourscriptname.sh (if present) will be substituted between +# +# + +yourscriptname.ps1 (if present) will be substituted between +# +# + + +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: + +# +# + +# +# + + +# +#/ + +# +# + +The .wrapconf file can have comment lines (beginning with # and possibly whitespace) + +e.g myutility.wrapconf might contain: +#------------------------ +tagdata file myutility_download-tclkit2.sh +tagdata line {# code to verify download follows} +tagdata file myutility_download-tclkit2_verification.sh +tagdata file myutility_launch-with-tclkit2.sh +tagdata file myutility_download-tclkit2.ps1 +tagdata 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 vs a paired set .. + +paired tags must have their opening and closing tags on different lines. +hence the following line is invalid. +# something etc # 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 and once for closing or just once for self-closing tag ) +#------------------------ +#replacement of a singleton tag +tagline line {@set "nextshell=tclsh" & :: @} +#replacement of closing tag of a paired-tag +tagline line {# 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 +#------------------------ + + + + + + diff --git a/src/modules/punk/mix/templates/utility/multishell.cmd b/src/modules/punk/mix/templates/layouts/project/src/scriptapps/wrappers/sample_punk-multishell.cmd similarity index 100% rename from src/modules/punk/mix/templates/utility/multishell.cmd rename to src/modules/punk/mix/templates/layouts/project/src/scriptapps/wrappers/sample_punk-multishell.cmd diff --git a/src/modules/punk/mix/templates/utility/shellbat.txt b/src/modules/punk/mix/templates/layouts/project/src/scriptapps/wrappers/sample_punk-shellbat.bat similarity index 95% rename from src/modules/punk/mix/templates/utility/shellbat.txt rename to src/modules/punk/mix/templates/layouts/project/src/scriptapps/wrappers/sample_punk-shellbat.bat index 25c7d1d8..aa9039a9 100644 --- a/src/modules/punk/mix/templates/utility/shellbat.txt +++ b/src/modules/punk/mix/templates/layouts/project/src/scriptapps/wrappers/sample_punk-shellbat.bat @@ -26,6 +26,7 @@ # +# # --- --- --- --- --- --- --- --- --- --- --- --- --- # only exit if needed. see exitcode notes at bottom of file and exit there for consistency across invocation methods @@ -55,17 +56,24 @@ then #-- #printf "start of bash or sh code" + # + # - #-- sh/bash launches Tcl here instead of shebang line at top + #-- sh/bash launches Tcl here instead of shebang line at top + # #-- use exec to use exitcode (if any) directly from the tcl script exec /usr/bin/env tclsh "$0" "$@" + # #-- alternative - if sh/bash script required to run after the tcl call. #/usr/bin/env tclsh "$0" "$@" #tcl_exitcode=$? #echo "tcl_exitcode: ${tcl_exitcode}" + # + # + #-- override exitcode example #exit 66 diff --git a/src/modules/punk/mix/templates/utility/scriptappwrappers/punk-multishell.cmd b/src/modules/punk/mix/templates/utility/scriptappwrappers/punk-multishell.cmd new file mode 100644 index 00000000..1cb9e0ef --- /dev/null +++ b/src/modules/punk/mix/templates/utility/scriptappwrappers/punk-multishell.cmd @@ -0,0 +1,270 @@ +set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershell;proc Hide s {proc $s args {}}; Hide :;rename set s2;Hide set;s2 1 list]"; set -- : "$@"; $1 = @' +: heredoc1 - hide from powershell (close sqote for unix shells) ' \ +: << 'HEREDOC1B_HIDE_FROM_BASH_AND_SH' +: .bat/.cmd launch section, leading colon hides from cmd, trailing slash hides next line from tcl \ +: "[Hide @ECHO; Hide ); Hide (;Hide echo]#not necessary but can help avoid errs in testing" +: Continuation char at end of this line and rem with curly-braces used to exlude Tcl from the whole cmd block \ +@REM { +@REM DO NOT MODIFY FIRST LINE OF THIS SCRIPT. shebang #! line is not required and will reduce functionality. +@REM Even comment lines can be part of the functionality of this script - modify with care. +@REM Change the value of nextshell in the next line if desired, and code within payload sections as appropriate. +@SET "nextshell=pwsh" +@REM nextshell set to pwsh,sh,bash or tclsh +@REM @ECHO nextshell is %nextshell% +@SET "validshells=pwsh,sh,bash,tclsh" +@CALL SET keyRemoved=%%validshells:%nextshell%=%% +@REM Note that 'powershell' e.g v5 is just a fallback for when pwsh is not available +@REM ## ### ### ### ### ### ### ### ### ### ### ### ### ### +@REM -- cmd/batch file section (ignored on unix) +@REM -- This section intended only to launch the next shell +@REM -- Avoid customising this if possible. cmd/batch script is probably the least expressive language. +@REM -- custom windows payloads should be in powershell,tclsh or sh/bash code sections +@REM ## ### ### ### ### ### ### ### ### ### ### ### ### ### +@SETLOCAL EnableExtensions EnableDelayedExpansion +@SET "winpath=%~dp0" +@SET "fname=%~nx0" +@REM @ECHO fname %fname% +@REM @ECHO winpath %winpath% +@IF %nextshell%==pwsh ( + CALL pwsh -nop -c set-executionpolicy -Scope CurrentUser RemoteSigned + COPY "%~dp0%~n0.cmd" "%~dp0%~n0.ps1" >NUL + REM test availability of preferred option of powershell7+ pwsh + CALL pwsh -nop -nol -c write-host "statusmessage: pwsh-found" >NUL + SET pwshtest_exitcode=!errorlevel! + REM ECHO pwshtest_exitcode !pwshtest_exitcode! + IF !pwshtest_exitcode!==0 CALL pwsh -nop -nol "%~dp0%~n0.ps1" %* & SET task_exitcode=!errorlevel! + REM fallback to powershell if pwsh failed + IF NOT !pwshtest_exitcode!==0 ( + REM CALL powershell -nop -nol -c write-host powershell-found + CALL powershell -nop -nol -file "%~dp0%~n0.ps1" %* + SET task_exitcode=!errorlevel! + ) +) ELSE ( + IF %nextshell%==bash ( + CALL :getWslPath %winpath% wslpath + REM ECHO wslfullpath "!wslpath!%fname%" + CALL %nextshell% "!wslpath!%fname%" %* & SET task_exitcode=!errorlevel! + ) ELSE ( + REM probably tclsh or sh + IF NOT "x%keyRemoved%"=="x%validshells%" ( + REM sh uses /c/ instead of /mnt/c - at least if using msys. Todo, review what is the norm on windows with and without msys2,cygwin,wsl + REM and what logic if any may be needed. For now sh with /c/xxx seems to work the same as sh with c:/xxx + CALL %nextshell% "%~dp0%fname%" %* & SET task_exitcode=!errorlevel! + ) ELSE ( + ECHO %fname% has invalid nextshell value %nextshell% valid options are %validshells% + SET task_exitcode=66 + GOTO :exit + ) + ) +) +@GOTO :endlib +:getWslPath +@SETLOCAL + @SET "_path=%~p1" + @SET "name=%~nx1" + @SET "drive=%~d1" + @SET "rtrn=%~2" + @SET "result=/mnt/%drive:~0,1%%_path:\=/%%name%" +@ENDLOCAL & ( + @if "%~2" neq "" ( + SET "%rtrn%=%result%" + ) ELSE ( + ECHO %result% + ) +) +@GOTO :eof +:endlib + +: \ +@REM @SET taskexit_code=!errorlevel! & goto :exit +@GOTO :exit +# } +# rem call %nextshell% "%~dp0%~n0.cmd" %* +# -*- tcl -*- +# ## ### ### ### ### ### ### ### ### ### ### ### ### ### +# -- tcl script section +# -- This is a punk multishell file +# -- Primary payload target is Tcl, with sh,bash,powershell as helpers +# -- but it may equally be used with any of these being the primary script. +# -- It is tuned to run when called as a batch file, a tcl script a sh/bash script or a pwsh/powershell script +# -- i.e it is a polyglot file. +# -- The specific layout including some lines that appear just as comments is 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.polypunk.cmd in sh or bash +# -- e.g tclsh filename.cmd +# -- +# ## ### ### ### ### ### ### ### ### ### ### ### ### ### +rename set ""; rename s2 set; set k {-- "$@" "a}; if {[info exists ::env($k)]} {unset ::env($k)} ;# tidyup +Hide :exit;Hide {<#};Hide '@ +namespace eval ::punk::multishell { + set last_script_root [file dirname [file normalize ${argv0}/__]] + set last_script [file dirname [file normalize [info script]/__]] + if {[info exists argv0] && + $last_script eq $last_script_root + } { + set ::punk::multishell::is_main($last_script) 1 ;#run as executable/script - likely desirable to launch application and return an exitcode + } else { + set ::punk::multishell::is_main($last_script) 0 ;#sourced - likely to be being used as a library - no launch, no exit. Can use return. + } + if {"::punk::multishell::is_main" ni [info commands ::punk::multishell::is_main]} { + proc ::punk::multishell::is_main {{script_name {}}} { + if {$script_name eq ""} { + set script_name [file dirname [file normalize [info script]/--]] + } + if {![info exists ::punk::multishell::is_main($script_name)]} { + #e.g a .dll or something else unanticipated + puts stderr "Warning punk::multishell didn't recognize info script result: $script_name - will treat as if sourced and return instead of exiting" + puts stderr "Info: script_root: [file dirname [file normalize ${argv0}/__]]" + return 0 + } + return [set ::punk::multishell::is_main($script_name)] + } + } +} +# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl Payload +#puts "script : [info script]" +#puts "argcount : $::argc" +#puts "argvalues: $::argv" +#puts "argv0 : $::argv0" +# -- --- --- --- --- --- --- --- --- --- --- --- + + +# +# + + + +# -- --- --- --- --- --- --- --- --- --- --- --- +# -- Best practice is to always return or exit above, or just by leaving the below defaults in place. +# -- If the multishell script is modified to have Tcl below the Tcl Payload section, +# -- then Tcl bracket balancing needs to be carefully managed in the shell and powershell sections below. +# -- Only the # in front of the two relevant if statements below needs to be removed to enable Tcl below +# -- but the sh/bash 'then' and 'fi' would also need to be uncommented. +# -- This facility left in place for experiments on whether configuration payloads etc can be appended +# -- to tail of file - possibly binary with ctrl-z char - but utility is dependent on which other interpreters/shells +# -- can be made to ignore/cope with such data. +if {[::punk::multishell::is_main]} { + exit 0 +} else { + return +} +# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl Payload +# end hide from unix shells \ +HEREDOC1B_HIDE_FROM_BASH_AND_SH +# sh/bash \ +shift && set -- "${@:1:$#-1}" +#------------------------------------------------------ +# -- This if block only needed if Tcl didn't exit or return above. +if false==false # else { + then + : +# ## ### ### ### ### ### ### ### ### ### ### ### ### ### +# -- sh/bash script section +# -- leave as is if all that is required is launching the Tcl payload" +# -- +# -- Note that sh/bash script isn't called when running a .bat/.cmd from cmd.exe on windows by default +# -- adjust @call line above ... to something like @call sh ... @call bash .. or @call env sh ... etc as appropriate +# -- if sh/bash scripting needs to run on windows too. +# -- +# ## ### ### ### ### ### ### ### ### ### ### ### ### ### +# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin sh Payload +#printf "start of bash or sh code" + +# +# + +# -- --- --- --- --- --- --- --- +# +exitcode=0 ;#default assumption +#-- sh/bash launches Tcl here instead of shebang line at top +#-- use exec to use exitcode (if any) directly from the tcl script +#exec /usr/bin/env tclsh "$0" "$@" +#-- alternative - can run sh/bash script after the tcl call. +/usr/bin/env tclsh "$0" "$@" +exitcode=$? +#echo "tcl exitcode: ${exitcode}" +#-- override exitcode example +#exit 66 +# +# -- --- --- --- --- --- --- --- + +# +# + + +#printf "sh/bash done \n" +# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end sh Payload +#------------------------------------------------------ +fi +exit ${exitcode} +# end hide sh/bash block from Tcl +# This comment with closing brace should stay in place whether if commented or not } +#------------------------------------------------------ +# begin hide powershell-block from Tcl - only needed if Tcl didn't exit or return above +if 0 { +: end heredoc1 - end hide from powershell \ +'@ +# ## ### ### ### ### ### ### ### ### ### ### ### ### ### +# -- powershell/pwsh section +# -- +# ## ### ### ### ### ### ### ### ### ### ### ### ### ### +function GetScriptName { $myInvocation.ScriptName } +$scriptname = getScriptName +# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin powershell Payload +#"Timestamp : {0,10:yyyy-MM-dd HH:mm:ss}" -f $(Get-Date) | write-host +#"Script Name : {0}" -f $scriptname | write-host +#"Powershell Version: {0}" -f $PSVersionTable.PSVersion.Major | write-host +#"powershell args : {0}" -f ($args -join ", ") | write-host +# -- --- --- --- + +# +# + + +# -- --- --- --- --- --- --- --- +# +tclsh $scriptname $args +# +# -- --- --- --- --- --- --- --- + + +# +# + +# unbal } + +# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end powershell Payload +#"powershell reporting exitcode: {0}" -f $LASTEXITCODE | write-host +Exit $LASTEXITCODE +# heredoc2 for powershell to ignore block below +$1 = @' +' +: end hide powershell-block from Tcl \ +# This comment with closing brace should stay in place whether 'if' commented or not } +: cmd exit label - return exitcode +:exit +: \ +@REM @ECHO exitcode: !task_exitcode! +: \ +@EXIT /B !task_exitcode! +# cmd has exited +: end heredoc2 \ +'@ +<# +# id:tailblock0 +# -- powershell multiline comment +#> +<# +# id:tailblock1 +# + +# +# -- unreachable by tcl directly if ctrl-z character is in the section above. (but file can be read and split on \x1A) +# -- Potential for zip and/or base64 contents, but we can't stop pwsh parser from slurping in the data +# -- so for example a plain text tar archive could cause problems depending on the content. +# -- final line in file must be the powershell multiline comment terminator or other data it can handle. +# -- e.g plain # comment lines will work too +# -- (for example a powershell digital signature is a # commented block of data at the end of the file) +#> + + diff --git a/src/modules/punk/mix/templates/utility/scriptappwrappers/punk-shellbat.bat b/src/modules/punk/mix/templates/utility/scriptappwrappers/punk-shellbat.bat new file mode 100644 index 00000000..aa9039a9 --- /dev/null +++ b/src/modules/punk/mix/templates/utility/scriptappwrappers/punk-shellbat.bat @@ -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" + + +# +# + +# --- --- --- --- --- --- --- --- --- --- --- --- --- +# 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" + + # + # + + + #-- sh/bash launches Tcl here instead of shebang line at top + # + #-- use exec to use exitcode (if any) directly from the tcl script + exec /usr/bin/env tclsh "$0" "$@" + # + + #-- alternative - if sh/bash script required to run after the tcl call. + #/usr/bin/env tclsh "$0" "$@" + #tcl_exitcode=$? + #echo "tcl_exitcode: ${tcl_exitcode}" + + # + # + + #-- 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 + diff --git a/src/modules/punk/timeinterval-999999.0a1.0.tm b/src/modules/punk/timeinterval-999999.0a1.0.tm new file mode 100644 index 00000000..e0815eb9 --- /dev/null +++ b/src/modules/punk/timeinterval-999999.0a1.0.tm @@ -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 -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 +# @@ 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 diff --git a/src/modules/punk/timeinterval-buildversion.txt b/src/modules/punk/timeinterval-buildversion.txt new file mode 100644 index 00000000..f47d01c8 --- /dev/null +++ b/src/modules/punk/timeinterval-buildversion.txt @@ -0,0 +1,3 @@ +0.1.0 +#First line must be a semantic version number +#all other lines are ignored. diff --git a/src/modules/punk/winpath-999999.0a1.0.tm b/src/modules/punk/winpath-999999.0a1.0.tm index bea9d5e7..e4d611ea 100644 --- a/src/modules/punk/winpath-999999.0a1.0.tm +++ b/src/modules/punk/winpath-999999.0a1.0.tm @@ -202,7 +202,19 @@ namespace eval punk::winpath { } #we don't validate that path is actually illegal because we don't know the full range of such names. #The caller can apply this to any path. - #don't test for platform here - needs to be callable from any platform for potential passing to windows + #don't test for platform here - needs to be callable from any platform for potential passing to windows (what usecase? 8.3 name is not always calculable independently) + #The utility of this is questionable. prepending a dos-device path won't make a filename with illegal characters readable by windows. + #It will need the 'shortname' at least for the illegal segment - if not the whole path + #Whilst the 8.3 name algorithm - including undocumented hash function has been reverse engineered + #- it depends on the content of the directory - as collisions cause a different name (e.g incremented number) + #- it also depends on the history of the folder + #- you can't take the current dir contents and a particular *existing* longname and determine the shortname algorithmically... + #- the shortname may have been generated during a different directory state. + #- It is then stored on disk (where?) - so access to reading the existing shortname is required. + #- An implementation of the 8.3 algorithm would only be potentially useful in determining the name that will result from adding a new file + # and would be subject to potential collisions if there are race-conditions in file creation + #- Using an 8.3 algorithm externally would be dangerous in that it could appear to work a lot of the time - but return a different file entirely sometimes. + #- Conclusion is that the 8.3 name must be retrieved rathern than calclated proc illegalname_fix {path} { #don't add extra dos device path syntax protection-prefix if already done if {[is_unc_path $path]} { @@ -258,7 +270,7 @@ namespace eval punk::winpath { #don't test for platform here - needs to be callable from any platform for potential passing to windows #we can create files with windows illegal names by using //?/ dos device path syntax - but we need to detect when that is required. proc illegalname_test {path} { - #first test if already protected - we return false even if the file would be illegal without the protection! + #first test if already protected - we return false even if the file would be illegal without the protection? if {[is_dos_device_path $path]} { return 0 } diff --git a/src/modules/punkapp-0.1.tm b/src/modules/punkapp-0.1.tm index fc156569..88b76130 100644 --- a/src/modules/punkapp-0.1.tm +++ b/src/modules/punkapp-0.1.tm @@ -31,6 +31,20 @@ namespace eval punkapp { lappend list {*}[get_toplevels $w] } return $list + } + + proc make_toplevel_next {prefix} { + set top [get_toplevel_next $prefix] + return [toplevel $top] + } + #possible race condition if multiple calls made without actually creating the toplevel, or gap if highest existing closed in the meantime + #todo - reserve_toplevel_next ? keep list of toplevels considered 'allocated' even if never created or already destroyed? what usecase? + #can call wm withdraw to to reserve newly created toplevel. To stop re-use of existing names after destruction would require a list or at least a record of highest created for each prefix + proc get_toplevel_next {prefix} { + set base [string trim $prefix .] ;# .myapp -> myapp .myapp.somewindow -> myapp.somewindow . -> "" + + + } proc exit {{toplevel ""}} { set toplevels [get_toplevels] @@ -41,17 +55,29 @@ namespace eval punkapp { } } else { #review - puts stderr "punkapp::exit called without toplevel - showing console" - show_console - return 0 + if {[info exists ::repl::running] && $::repl::running} { + puts stderr "punkapp::exit called without toplevel - showing console" + show_console + return 0 + } else { + puts stderr "punkapp::exit called without toplevel - exiting" + ::exit + } } set controllable [get_user_controllable_toplevels] if {![llength $controllable]} { - show_console + #review - tight coupling + if {[info exists ::repl::running] && $::repl::running} { + show_console + } else { + ::exit + } } } - + + #A window can be 'visible' according to this - but underneath other windows etc + #REVIEW - change name? proc get_visible_toplevels {{w .}} { if {![llength [info commands winfo]]} { return [list] @@ -78,7 +104,7 @@ namespace eval punkapp { set controllable [list] foreach v $visible { if {[wm overrideredirect $v] == 0} { - append controllable $v + lappend controllable $v } } #only return visible windows with overrideredirect == 0 because there exists some user control. diff --git a/src/modules/shellfilter-0.1.8.tm b/src/modules/shellfilter-0.1.8.tm index 22382ded..b2af8802 100644 --- a/src/modules/shellfilter-0.1.8.tm +++ b/src/modules/shellfilter-0.1.8.tm @@ -34,8 +34,9 @@ namespace eval shellfilter::log { lappend sourcelist $tag } + #note new_worker set worker_tid [shellthread::manager::new_worker $tag $settingsdict] - + #puts stderr "shellfilter::log::open this_threadid: [thread::id] tag: $tag worker_tid: $worker_tid" return $worker_tid } proc write {tag msg} { @@ -46,7 +47,8 @@ namespace eval shellfilter::log { shellthread::manager::write_log $tag $msg -async 0 } proc close {tag} { - shellthread::manager::close_worker $tag + #shellthread::manager::close_worker $tag + shellthread::manager::unsubscribe [list $tag]; #workertid will be added back to free list if no tags remain subscribed } #todo -implement @@ -68,7 +70,7 @@ namespace eval shellfilter::log { } } namespace eval shellfilter::pipe { - #write channel for program. workethread reads other end of fifo2 and writes data somewhere + #write channel for program. workerthread reads other end of fifo2 and writes data somewhere proc open_out {tag_pipename {settingsdict {}}} { package require shellthread #we are only using the fifo in a single direction to pipe to another thread @@ -89,6 +91,7 @@ namespace eval shellfilter::pipe { chan configure $rchan -buffering [dict get $settingsdict -buffering] -translation lf set worker_tid [shellthread::manager::new_worker $tag_pipename $settingsdict] + #puts stderr "worker_tid: $worker_tid" #set_read_pipe does the thread::transfer of the rchan end. -buffering setting is maintained during thread transfer shellthread::manager::set_pipe_read_from_client $tag_pipename $worker_tid $rchan @@ -958,6 +961,7 @@ namespace eval shellfilter::stack { proc get_next_counter {pipename} { variable pipelines + #use dictn incr ? set counter [dict get $pipelines $pipename counter] incr counter dict set pipelines $pipename counter $counter diff --git a/src/modules/shellthread-1.6.tm b/src/modules/shellthread-1.6.tm index 3a1926e3..574dbda5 100644 --- a/src/modules/shellthread-1.6.tm +++ b/src/modules/shellthread-1.6.tm @@ -370,7 +370,8 @@ namespace eval shellthread::manager { variable workers [dict create] variable worker_errors [list] - variable log_threads + variable free_threads [list] + #variable log_threads #new datastructure regarding workers and sourcetags required. #one worker can service multiple sourcetags - but each sourcetag may be used by multiple threads too. @@ -382,14 +383,10 @@ namespace eval shellthread::manager { #it can join with both the primary tag and a tag it will actually use for logging. #A thread can join the logger with any existingtag - not just the 'primary' #(which is arbitrary anyway. It will usually be the first in the list - but may be unsubscribed by clients and disappear) - proc join_worker {client_tid existingtag sourcetaglist} { + proc join_worker {existingtag sourcetaglist} { + set client_tid [thread::id] #todo - allow a source to piggyback on existing worker by referencing one of the sourcetags already using the worker } - proc leave_worker {client_tid sourcetaglist} { - #todo - #unsub this client_tid from the sourcetags in the sourcetaglist. if no more client_tids exist for sourcetag, remove sourcetag, - #if no more sourcetags - close worker - } #it is up to caller to use a unique sourcetag (e.g by prefixing with own thread::id etc) # This allows multiple threads to more easily write to the same named sourcetag if necessary # todo - change sourcetag for a list of tags which will be handled by the same thread. e.g for multiple threads logging to same file @@ -417,6 +414,21 @@ namespace eval shellthread::manager { return [dict get $winfo tid] } } + + #check if there is an existing unsubscribed thread first + variable free_threads + if {[llength $free_threads]} { + #todo - re-use from tail - as most likely to have been doing similar work?? review + + set free_threads [lassign $free_threads tidworker] + #todo - keep track of real ts_start of free threads... kill when too old + set winfo [dict create tid $tidworker list_client_tids [list $tidclient] ts_start $ts_start ts_end_list [list]] + puts stderr "shellfilter::new_worker Re-using free worker thread: $tidworker with tag $sourcetag" + dict set workers $sourcetag $winfo + return $tidworker + } + + #set ts_start [::shellthread::iso8601] set tidworker [thread::create -preserved] set init_script [string map [list %ts_start% $ts_start %mp% [tcl::tm::list] %ap% $::auto_path %tidcli% $tidclient %sd% $settingsdict] { @@ -523,14 +535,97 @@ namespace eval shellthread::manager { } } } + + #aka leave_worker + #Note that the tags may be on separate workertids, or some tags may share workertids + proc unsubscribe {sourcetaglist} { + variable workers + #workers structure example: + #[list sourcetag1 [list tid list_client_tids ] ts_start ts_end_list {}] + variable free_threads + set mytid [thread::id] ;#caller of shellthread::manager::xxx is the client thread + + set subscriberless_tags [list] + foreach source $sourcetaglist { + if {[dict exists $workers $source]} { + set list_client_tids [dict get $workers $source list_client_tids] + if {[set posn [lsearch $list_client_tids $mytid]] >= 0} { + set list_client_tids [lreplace $list_client_tids $posn $posn] + dict set workers $source list_client_tids $list_client_tids + } + if {![llength $list_client_tids]} { + lappend subscriberless_tags $source + } + } + } + + #we've removed our own tid from all the tags - possibly across multiplew workertids, and possibly leaving some workertids with no subscribers for a particular tag - or no subscribers at all. + + set subscriberless_workers [list] + set shuttingdown_workers [list] + foreach deadtag $subscriberless_tags { + set workertid [dict get $workers $deadtag tid] + set worker_tags [get_worker_tagstate $workertid] + set subscriber_count 0 + set kill_count 0 ;#number of ts_end_list entries - even one indicates thread is doomed + foreach taginfo $worker_tags { + incr subscriber_count [llength [dict get $taginfo list_client_tids]] + incr kill_count [llength [dict get $taginfo ts_end_list]] + } + if {$subscriber_count == 0} { + lappend subscriberless_workers $workertid + } + if {$kill_count > 0} { + lappend shuttingdown_workers $workertid + } + } + + #if worker isn't shutting down - add it to free_threads list + foreach workertid $subscriberless_workers { + if {$workertid ni $shuttingdown_workers} { + if {$workertid ni $free_threads} { + lappend free_threads $workertid + } + } + } + + #todo + #unsub this client_tid from the sourcetags in the sourcetaglist. if no more client_tids exist for sourcetag, remove sourcetag, + #if no more sourcetags - add worker to free_threads + } + proc get_worker_tagstate {workertid} { + variable workers + set taginfo_list [list] + dict for {source sourceinfo} $workers { + if {[dict get $sourceinfo tid] eq $workertid} { + lappend taginfo_list $sourceinfo + } + } + return $taginfo_list + } + + #instruction to shut-down the thread that has this source. proc close_worker {source {timeout 2500}} { variable workers variable worker_errors + variable free_threads set ts_now [clock micros] #puts stderr "close_worker $source" if {[dict exists $workers $source]} { set tidworker [dict get $workers $source tid] - set ts_end_list [dict get $workers $source ts_end_list] + if {$tidworker in $freethreads} { + #make sure a thread that is being closed is removed from the free_threads list + set posn [lsearch $freethreads $tidworker] + set freethreads [lreplace $freethreads $posn $posn] + } + set mytid [thread::id] + set client_tids [dict get $workers $source list_client_tids] + if {[set posn [lsearch $client_tids $mytid]] >= 0} { + set client_tids [lreplace $client_tids $posn $posn] + #remove self from list of clients + dict set workers $source list_client_tids $client_tids + } + set ts_end_list [dict get $workers $source ts_end_list] ;#ts_end_list is just a list of timestamps of closing calls for this source - only one is needed to close, but they may all come in a flurry. if {[llength $ts_end_list]} { set last_end_ts [lindex $ts_end_list end] if {[expr {(($tsnow - $last_end_ts) / 1000) >= $timeout}]} { @@ -566,6 +661,14 @@ namespace eval shellthread::manager { } } dict unset workers $source + } else { + #thread may have been closed by call to close_worker with another source with same worker + #clear workers record for this source + #REVIEW - race condition for re-creation of source with new workerid? + #check that record is subscriberless to avoid this + if {[llength [dict get $workers $source list_client_tids]] == 0} { + dict unset workers $source + } } } #puts stdout "close_worker $source - end" diff --git a/src/modules/tcl9test-999999.0a1.0.tm b/src/modules/tcl9test-999999.0a1.0.tm new file mode 100644 index 00000000..aacdf497 --- /dev/null +++ b/src/modules/tcl9test-999999.0a1.0.tm @@ -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 -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 +# @@ 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 diff --git a/src/modules/tcl9test-buildversion.txt b/src/modules/tcl9test-buildversion.txt new file mode 100644 index 00000000..f47d01c8 --- /dev/null +++ b/src/modules/tcl9test-buildversion.txt @@ -0,0 +1,3 @@ +0.1.0 +#First line must be a semantic version number +#all other lines are ignored. diff --git a/src/modules/winlibreoffice-999999.0a1.0.tm b/src/modules/winlibreoffice-999999.0a1.0.tm new file mode 100644 index 00000000..6272abb1 --- /dev/null +++ b/src/modules/winlibreoffice-999999.0a1.0.tm @@ -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 -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 +# @@ 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)}] + #dateH: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 diff --git a/src/modules/winlibreoffice-buildversion.txt b/src/modules/winlibreoffice-buildversion.txt new file mode 100644 index 00000000..f47d01c8 --- /dev/null +++ b/src/modules/winlibreoffice-buildversion.txt @@ -0,0 +1,3 @@ +0.1.0 +#First line must be a semantic version number +#all other lines are ignored. diff --git a/src/punk86.vfs/lib/app-punk/repl.tcl b/src/punk86.vfs/lib/app-punk/repl.tcl index fdf69fa2..dbdaef56 100644 --- a/src/punk86.vfs/lib/app-punk/repl.tcl +++ b/src/punk86.vfs/lib/app-punk/repl.tcl @@ -8,31 +8,14 @@ package provide app-punk 1.0 #------------------------------------------------------------------------------ #Module loading #------------------------------------------------------------------------------ -#If the current directory contains .tm files when the punk repl starts - then it will attempt to preference them +#If the current directory contains .tm files when the punk repl starts - then it will attempt to preference them +# - but first add our other known relative modules paths - as it won't make sense to use current directory as a modulpath if it's an ancestor of one of these.. set original_tm_list [tcl::tm::list] tcl::tm::remove {*}$original_tm_list -set currentdir_modules [glob -nocomplain -dir [pwd] -type f -tail *.tm] -set tcl_core_packages [list tcl::zlib zlib tcl::oo TclOO tcl::tommath tcl::zipfs tcl Tcl] -if {[llength $currentdir_modules]} { - #only forget all *unloaded* package names if we are started in a .tm containing folder - foreach pkg [package names] { - if {$pkg in $tcl_core_packages} { - continue - } - if {![llength [package versions $pkg]]} { - #puts stderr "Got no versions for pkg $pkg" - continue - } - if {[catch {package present $pkg}]} { - package forget $pkg - } - } - tcl::tm::add [pwd] -} - +#1) if {[string match "*.vfs/*" [info script]]} { #src/xxx.vfs/lib/app-punk/repl.tcl #we assume if calling directly into .vfs that the user would prefer to use src/modules - so go up 4 levels @@ -49,9 +32,33 @@ if {[file exists $modulefolder]} { puts stderr "Warning unable to find module folder at: $modulefolder" } if {[file exists [pwd]/modules]} { - tcl::tm::add [pwd]/modules + catch {tcl::tm::add [pwd]/modules} } + +#2) +#now add current dir (if no conflict with above) +set currentdir_modules [glob -nocomplain -dir [pwd] -type f -tail *.tm] +set tcl_core_packages [list tcl::zlib zlib tcl::oo TclOO tcl::tommath tcl::zipfs Tcl Tk] +if {[llength $currentdir_modules]} { + #only forget all *unloaded* package names if we are started in a .tm containing folder + foreach pkg [package names] { + if {$pkg in $tcl_core_packages} { + continue + } + if {![llength [package versions $pkg]]} { + #puts stderr "Got no versions for pkg $pkg" + continue + } + if {![string length [package provide $pkg]]} { + package forget $pkg + } + } + catch {tcl::tm::add [pwd]} +} + + + package require Thread #These are strong dependencies # - the repl requires Threading and punk,shellfilter,shellrun to call and display properly. @@ -69,6 +76,8 @@ package require punk set tm_list_now [tcl::tm::list] foreach p $original_tm_list { if {$p ni $tm_list_now} { + #the prior tm paths go to the head of the list. + #They are processed first.. but an item of same version later in the list will override one at the head. tcl::tm::add $p } } diff --git a/src/punk86.vfs/main.tcl b/src/punk86.vfs/main.tcl index bf00b925..77e23048 100644 --- a/src/punk86.vfs/main.tcl +++ b/src/punk86.vfs/main.tcl @@ -1,6 +1,10 @@ -package require starkit -starkit::startup +if {[catch {package require starkit}]} { + #presumably running the xxx.vfs/main.tcl script using a non-starkit tclsh that doesn't have starkit lib available.. lets see if we can move forward anyway + lappend ::auto_path [file join [file dirname [info script]] lib] +} else { + starkit::startup +} #when run as a tclkit - the exe is mounted as a dir and Tcl's auto_execok doesn't find it set thisexe [file tail [info nameofexecutable]] diff --git a/src/scriptapps/tcltm b/src/scriptapps/tcltm new file mode 100644 index 00000000..eb4e8a04 --- /dev/null +++ b/src/scriptapps/tcltm @@ -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 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/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 diff --git a/src/scriptapps/wrappers/README.md b/src/scriptapps/wrappers/README.md new file mode 100644 index 00000000..604fb5be --- /dev/null +++ b/src/scriptapps/wrappers/README.md @@ -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 +# +# + +yourscriptname.sh (if present) will be substituted between +# +# + +yourscriptname.ps1 (if present) will be substituted between +# +# + + +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: + +# +# + +# +# + + +# +#/ + +# +# + +The .wrapconf file can have comment lines (beginning with # and possibly whitespace) + +e.g myutility.wrapconf might contain: +#------------------------ +tagdata file myutility_download-tclkit2.sh +tagdata file myutility_launch-with-tclkit2.sh +tagdata file myutility_download-tclkit2.ps1 +tagdata 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 vs a paired set .. + +paired tags must have their opening and closing tags on different lines. +hence the following line is invalid. +# something etc # 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 line {@set "nextshell=tclsh" & :: @} +#replacement of closing tag of a paired-tag +tagline line {# 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 +#------------------------ + + + + + + diff --git a/src/scriptapps/wrappers/sample_punk-multishell.cmd b/src/scriptapps/wrappers/sample_punk-multishell.cmd new file mode 100644 index 00000000..9d903392 --- /dev/null +++ b/src/scriptapps/wrappers/sample_punk-multishell.cmd @@ -0,0 +1,264 @@ +set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershell;proc Hide s {proc $s args {}}; Hide :;rename set s2;Hide set;s2 1 list]"; set -- : "$@"; $1 = @' +: heredoc1 - hide from powershell (close sqote for unix shells) ' \ +: << 'HEREDOC1B_HIDE_FROM_BASH_AND_SH' +: .bat/.cmd launch section, leading colon hides from cmd, trailing slash hides next line from tcl \ +: "[Hide @ECHO; Hide ); Hide (;Hide echo]#not necessary but can help avoid errs in testing" +: Continuation char at end of this line and rem with curly-braces used to exlude Tcl from the whole cmd block \ +@REM { +@REM DO NOT MODIFY FIRST LINE OF THIS SCRIPT. shebang #! line is not required and will reduce functionality. +@REM Even comment lines can be part of the functionality of this script - modify with care. +@REM Change the value of nextshell in the next line if desired, and code within payload sections as appropriate. +@SET "nextshell=pwsh" +@REM nextshell set to pwsh,sh,bash or tclsh +@REM @ECHO nextshell is %nextshell% +@SET "validshells=pwsh,sh,bash,tclsh" +@CALL SET keyRemoved=%%validshells:%nextshell%=%% +@REM Note that 'powershell' e.g v5 is just a fallback for when pwsh is not available +@REM ## ### ### ### ### ### ### ### ### ### ### ### ### ### +@REM -- cmd/batch file section (ignored on unix) +@REM -- This section intended only to launch the next shell +@REM -- Avoid customising this if possible. cmd/batch script is probably the least expressive language. +@REM -- custom windows payloads should be in powershell,tclsh or sh/bash code sections +@REM ## ### ### ### ### ### ### ### ### ### ### ### ### ### +@SETLOCAL EnableExtensions EnableDelayedExpansion +@SET "winpath=%~dp0" +@SET "fname=%~nx0" +@REM @ECHO fname %fname% +@REM @ECHO winpath %winpath% +@IF %nextshell%==pwsh ( + CALL pwsh -nop -c set-executionpolicy -Scope CurrentUser RemoteSigned + COPY "%~dp0%~n0.cmd" "%~dp0%~n0.ps1" >NUL + REM test availability of preferred option of powershell7+ pwsh + CALL pwsh -nop -nol -c write-host "statusmessage: pwsh-found" >NUL + SET pwshtest_exitcode=!errorlevel! + REM ECHO pwshtest_exitcode !pwshtest_exitcode! + IF !pwshtest_exitcode!==0 CALL pwsh -nop -nol "%~dp0%~n0.ps1" %* & SET task_exitcode=!errorlevel! + REM fallback to powershell if pwsh failed + IF NOT !pwshtest_exitcode!==0 ( + REM CALL powershell -nop -nol -c write-host powershell-found + CALL powershell -nop -nol -file "%~dp0%~n0.ps1" %* + SET task_exitcode=!errorlevel! + ) +) ELSE ( + IF %nextshell%==bash ( + CALL :getWslPath %winpath% wslpath + REM ECHO wslfullpath "!wslpath!%fname%" + CALL %nextshell% "!wslpath!%fname%" %* & SET task_exitcode=!errorlevel! + ) ELSE ( + REM probably tclsh or sh + IF NOT "x%keyRemoved%"=="x%validshells%" ( + REM sh uses /c/ instead of /mnt/c - at least if using msys. Todo, review what is the norm on windows with and without msys2,cygwin,wsl + REM and what logic if any may be needed. For now sh with /c/xxx seems to work the same as sh with c:/xxx + CALL %nextshell% "%~dp0%fname%" %* & SET task_exitcode=!errorlevel! + ) ELSE ( + ECHO %fname% has invalid nextshell value %nextshell% valid options are %validshells% + SET task_exitcode=66 + GOTO :exit + ) + ) +) +@GOTO :endlib +:getWslPath +@SETLOCAL + @SET "_path=%~p1" + @SET "name=%~nx1" + @SET "drive=%~d1" + @SET "rtrn=%~2" + @SET "result=/mnt/%drive:~0,1%%_path:\=/%%name%" +@ENDLOCAL & ( + @if "%~2" neq "" ( + SET "%rtrn%=%result%" + ) ELSE ( + ECHO %result% + ) +) +@GOTO :eof +:endlib + +: \ +@REM @SET taskexit_code=!errorlevel! & goto :exit +@GOTO :exit +# } +# rem call %nextshell% "%~dp0%~n0.cmd" %* +# -*- tcl -*- +# ## ### ### ### ### ### ### ### ### ### ### ### ### ### +# -- tcl script section +# -- This is a punk multishell file +# -- Primary payload target is Tcl, with sh,bash,powershell as helpers +# -- but it may equally be used with any of these being the primary script. +# -- It is tuned to run when called as a batch file, a tcl script a sh/bash script or a pwsh/powershell script +# -- i.e it is a polyglot file. +# -- The specific layout including some lines that appear just as comments is 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.polypunk.cmd in sh or bash +# -- e.g tclsh filename.cmd +# -- +# ## ### ### ### ### ### ### ### ### ### ### ### ### ### +rename set ""; rename s2 set; set k {-- "$@" "a}; if {[info exists ::env($k)]} {unset ::env($k)} ;# tidyup +Hide :exit;Hide {<#};Hide '@ +namespace eval ::punk::multishell { + set last_script_root [file dirname [file normalize ${argv0}/__]] + set last_script [file dirname [file normalize [info script]/__]] + if {[info exists argv0] && + $last_script eq $last_script_root + } { + set ::punk::multishell::is_main($last_script) 1 ;#run as executable/script - likely desirable to launch application and return an exitcode + } else { + set ::punk::multishell::is_main($last_script) 0 ;#sourced - likely to be being used as a library - no launch, no exit. Can use return. + } + if {"::punk::multishell::is_main" ni [info commands ::punk::multishell::is_main]} { + proc ::punk::multishell::is_main {{script_name {}}} { + if {$script_name eq ""} { + set script_name [file dirname [file normalize [info script]/--]] + } + return [set ::punk::multishell::is_main($script_name)] + } + } +} +# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl Payload +#puts "script : [info script]" +#puts "argcount : $::argc" +#puts "argvalues: $::argv" +#puts "argv0 : $::argv0" +# -- --- --- --- --- --- --- --- --- --- --- --- + + +# +# + + + +# -- --- --- --- --- --- --- --- --- --- --- --- +# -- Best practice is to always return or exit above, or just by leaving the below defaults in place. +# -- If the multishell script is modified to have Tcl below the Tcl Payload section, +# -- then Tcl bracket balancing needs to be carefully managed in the shell and powershell sections below. +# -- Only the # in front of the two relevant if statements below needs to be removed to enable Tcl below +# -- but the sh/bash 'then' and 'fi' would also need to be uncommented. +# -- This facility left in place for experiments on whether configuration payloads etc can be appended +# -- to tail of file - possibly binary with ctrl-z char - but utility is dependent on which other interpreters/shells +# -- can be made to ignore/cope with such data. +if {[::punk::multishell::is_main]} { + exit 0 +} else { + return +} +# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl Payload +# end hide from unix shells \ +HEREDOC1B_HIDE_FROM_BASH_AND_SH +# sh/bash \ +shift && set -- "${@:1:$#-1}" +#------------------------------------------------------ +# -- This if block only needed if Tcl didn't exit or return above. +if false==false # else { + then + : +# ## ### ### ### ### ### ### ### ### ### ### ### ### ### +# -- sh/bash script section +# -- leave as is if all that is required is launching the Tcl payload" +# -- +# -- Note that sh/bash script isn't called when running a .bat/.cmd from cmd.exe on windows by default +# -- adjust @call line above ... to something like @call sh ... @call bash .. or @call env sh ... etc as appropriate +# -- if sh/bash scripting needs to run on windows too. +# -- +# ## ### ### ### ### ### ### ### ### ### ### ### ### ### +# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin sh Payload +#printf "start of bash or sh code" + +# +# + +# -- --- --- --- --- --- --- --- +# +exitcode=0 ;#default assumption +#-- sh/bash launches Tcl here instead of shebang line at top +#-- use exec to use exitcode (if any) directly from the tcl script +#exec /usr/bin/env tclsh "$0" "$@" +#-- alternative - can run sh/bash script after the tcl call. +/usr/bin/env tclsh "$0" "$@" +exitcode=$? +#echo "tcl exitcode: ${exitcode}" +#-- override exitcode example +#exit 66 +# +# -- --- --- --- --- --- --- --- + +# +# + + +#printf "sh/bash done \n" +# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end sh Payload +#------------------------------------------------------ +fi +exit ${exitcode} +# end hide sh/bash block from Tcl +# This comment with closing brace should stay in place whether if commented or not } +#------------------------------------------------------ +# begin hide powershell-block from Tcl - only needed if Tcl didn't exit or return above +if 0 { +: end heredoc1 - end hide from powershell \ +'@ +# ## ### ### ### ### ### ### ### ### ### ### ### ### ### +# -- powershell/pwsh section +# -- +# ## ### ### ### ### ### ### ### ### ### ### ### ### ### +function GetScriptName { $myInvocation.ScriptName } +$scriptname = getScriptName +# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin powershell Payload +#"Timestamp : {0,10:yyyy-MM-dd HH:mm:ss}" -f $(Get-Date) | write-host +#"Script Name : {0}" -f $scriptname | write-host +#"Powershell Version: {0}" -f $PSVersionTable.PSVersion.Major | write-host +#"powershell args : {0}" -f ($args -join ", ") | write-host +# -- --- --- --- + +# +# + + +# -- --- --- --- --- --- --- --- +# +tclsh $scriptname $args +# +# -- --- --- --- --- --- --- --- + + +# +# + +# unbal } + +# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end powershell Payload +#"powershell reporting exitcode: {0}" -f $LASTEXITCODE | write-host +Exit $LASTEXITCODE +# heredoc2 for powershell to ignore block below +$1 = @' +' +: end hide powershell-block from Tcl \ +# This comment with closing brace should stay in place whether 'if' commented or not } +: cmd exit label - return exitcode +:exit +: \ +@REM @ECHO exitcode: !task_exitcode! +: \ +@EXIT /B !task_exitcode! +# cmd has exited +: end heredoc2 \ +'@ +<# +# id:tailblock0 +# -- powershell multiline comment +#> +<# +# id:tailblock1 +# + +# +# -- unreachable by tcl directly if ctrl-z character is in the section above. (but file can be read and split on \x1A) +# -- Potential for zip and/or base64 contents, but we can't stop pwsh parser from slurping in the data +# -- so for example a plain text tar archive could cause problems depending on the content. +# -- final line in file must be the powershell multiline comment terminator or other data it can handle. +# -- e.g plain # comment lines will work too +# -- (for example a powershell digital signature is a # commented block of data at the end of the file) +#> + + diff --git a/src/scriptapps/wrappers/sample_punk-shellbat.bat b/src/scriptapps/wrappers/sample_punk-shellbat.bat new file mode 100644 index 00000000..aa9039a9 --- /dev/null +++ b/src/scriptapps/wrappers/sample_punk-shellbat.bat @@ -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" + + +# +# + +# --- --- --- --- --- --- --- --- --- --- --- --- --- +# 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" + + # + # + + + #-- sh/bash launches Tcl here instead of shebang line at top + # + #-- use exec to use exitcode (if any) directly from the tcl script + exec /usr/bin/env tclsh "$0" "$@" + # + + #-- alternative - if sh/bash script required to run after the tcl call. + #/usr/bin/env tclsh "$0" "$@" + #tcl_exitcode=$? + #echo "tcl_exitcode: ${tcl_exitcode}" + + # + # + + #-- 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 + diff --git a/src/vendormodules/cksum-1.1.4.tm b/src/vendormodules/cksum-1.1.4.tm new file mode 100644 index 00000000..0fb17981 --- /dev/null +++ b/src/vendormodules/cksum-1.1.4.tm @@ -0,0 +1,200 @@ +# cksum.tcl - Copyright (C) 2002 Pat Thoyts +# +# 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: diff --git a/src/vendormodules/natsort-0.1.1.5.tm b/src/vendormodules/natsort-0.1.1.5.tm index d1a3bdb7..85b9c40a 100644 --- a/src/vendormodules/natsort-0.1.1.5.tm +++ b/src/vendormodules/natsort-0.1.1.5.tm @@ -1,9 +1,5 @@ #! /usr/bin/env tclsh -package provide natsort [namespace eval natsort { - variable version - set version 0.1.1.5 -}] package require flagfilter namespace import ::flagfilter::check_flags @@ -1879,5 +1875,9 @@ namespace eval natsort { } +package provide natsort [namespace eval natsort { + variable version + set version 0.1.1.5 +}]