jn
/
punkshell
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

script wrapper, doc, make.tcl , shellthread fixes

master
Julian Noble 1 year ago
parent
a9094a8716
commit
f2d2a4d615
52 changed files with 6377 additions and 1663 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 207
      src/bootsupport/fileutil/decode-0.2.1.tm
  2. 28
      src/bootsupport/fileutil/multi-0.1.tm
  3. 645
      src/bootsupport/fileutil/multi/op-0.5.3.tm
  4. 74
      src/bootsupport/fileutil/paths-1.tm
  5. 504
      src/bootsupport/fileutil/traverse-0.6.tm
  6. 2
      src/bootsupport/lib/README.md
  7. 0
      src/bootsupport/modules/README.md
  8. 2
      src/bootsupport/modules/cksum-1.1.4.tm
  9. 933
      src/bootsupport/modules/cmdline-1.5.2.tm
  10. 2
      src/bootsupport/modules/fileutil-1.16.1.tm
  11. 52
      src/bootsupport/modules/punk/du-0.1.0.tm
  12. 123
      src/bootsupport/modules/punk/mix-0.2.tm
  13. 0
      src/bootsupport/modules/punk/repo-0.1.0.tm
  14. 0
      src/bootsupport/modules/punk/winpath-0.1.0.tm
  15. 189
      src/bootsupport/modules/struct/set-2.2.3.tm
  16. 189
      src/bootsupport/modules/struct/sets.tcl
  17. 93
      src/bootsupport/modules/struct/sets_c.tcl
  18. 452
      src/bootsupport/modules/struct/sets_tcl.tcl
  19. 275
      src/build.cmd
  20. 32
      src/make.tcl
  21. 63
      src/modules/anyname-0.2.tm
  22. 10
      src/modules/flagfilter-0.3.tm
  23. 57
      src/modules/punk-0.1.tm
  24. 116
      src/modules/punk/du-999999.0a1.0.tm
  25. 608
      src/modules/punk/mix-0.2.tm
  26. 13
      src/modules/punk/mix/templates/layouts/project/README.md
  27. 0
      src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/README.md
  28. 85
      src/modules/punk/mix/templates/layouts/project/src/make.tcl
  29. 99
      src/modules/punk/mix/templates/layouts/project/src/scriptapps/wrappers/README.md
  30. 0
      src/modules/punk/mix/templates/layouts/project/src/scriptapps/wrappers/sample_punk-multishell.cmd
  31. 10
      src/modules/punk/mix/templates/layouts/project/src/scriptapps/wrappers/sample_punk-shellbat.bat
  32. 270
      src/modules/punk/mix/templates/utility/scriptappwrappers/punk-multishell.cmd
  33. 112
      src/modules/punk/mix/templates/utility/scriptappwrappers/punk-shellbat.bat
  34. 559
      src/modules/punk/timeinterval-999999.0a1.0.tm
  35. 3
      src/modules/punk/timeinterval-buildversion.txt
  36. 16
      src/modules/punk/winpath-999999.0a1.0.tm
  37. 28
      src/modules/punkapp-0.1.tm
  38. 10
      src/modules/shellfilter-0.1.8.tm
  39. 119
      src/modules/shellthread-1.6.tm
  40. 72
      src/modules/tcl9test-999999.0a1.0.tm
  41. 3
      src/modules/tcl9test-buildversion.txt
  42. 246
      src/modules/winlibreoffice-999999.0a1.0.tm
  43. 3
      src/modules/winlibreoffice-buildversion.txt
  44. 49
      src/punk86.vfs/lib/app-punk/repl.tcl
  45. 8
      src/punk86.vfs/main.tcl
  46. 902
      src/scriptapps/tcltm
  47. 93
      src/scriptapps/wrappers/README.md
  48. 264
      src/scriptapps/wrappers/sample_punk-multishell.cmd
  49. 112
      src/scriptapps/wrappers/sample_punk-shellbat.bat
  50. 200
      src/vendormodules/cksum-1.1.4.tm
  51. 8
      src/vendormodules/natsort-0.1.1.5.tm

207
src/bootsupport/fileutil/decode-0.2.1.tm
Unescape View File

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

28
src/bootsupport/fileutil/multi-0.1.tm
Unescape View File

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

645
src/bootsupport/fileutil/multi/op-0.5.3.tm
Unescape View File

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

74
src/bootsupport/fileutil/paths-1.tm
Unescape View File

@ -1,74 +0,0 @@
# paths.tcl --
#
# Manage lists of search paths.
#
# Copyright (c) 2009-2019 Andreas Kupries <andreas_kupries@sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Each object instance manages a list of paths.
# ### ### ### ######### ######### #########
## Requisites
package require Tcl 8.4
package require snit
# ### ### ### ######### ######### #########
## API
snit::type ::fileutil::paths {
# ### ### ### ######### ######### #########
## Options :: None
# ### ### ### ######### ######### #########
## Creation, destruction
# Default constructor.
# Default destructor.
# ### ### ### ######### ######### #########
## Methods :: Querying and manipulating the list of paths.
method paths {} {
return $mypaths
}
method add {path} {
set pos [lsearch $mypaths $path]
if {$pos >= 0 } return
lappend mypaths $path
return
}
method remove {path} {
set pos [lsearch $mypaths $path]
if {$pos < 0} return
set mypaths [lreplace $mypaths $pos $pos]
return
}
method clear {} {
set mypaths {}
return
}
# ### ### ### ######### ######### #########
## Internal methods :: None
# ### ### ### ######### ######### #########
## State :: List of paths.
variable mypaths {}
##
# ### ### ### ######### ######### #########
}
# ### ### ### ######### ######### #########
## Ready
package provide fileutil::paths 1
return

504
src/bootsupport/fileutil/traverse-0.6.tm
Unescape View File

@ -1,504 +0,0 @@
# traverse.tcl --
#
# Directory traversal.
#
# Copyright (c) 2006-2015 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require Tcl 8.3
# OO core
if {[package vsatisfies [package present Tcl] 8.5]} {
# Use new Tcl 8.5a6+ features to specify the allowed packages.
# We can use anything above 1.3. This means v2 as well.
package require snit 1.3-
} else {
# For Tcl 8.{3,4} only snit1 of a suitable patchlevel is possible.
package require snit 1.3
}
package require control ; # Helpers for control structures
package require fileutil ; # -> fullnormalize
snit::type ::fileutil::traverse {
# Incremental directory traversal.
# API
# create %AUTO% basedirectory options... -> object
# next filevar -> boolean
# foreach filevar script
# files -> list (path ...)
# Options
# -prefilter command-prefix
# -filter command-prefix
# -errorcmd command-prefix
# Use cases
#
# (a) Basic incremental
# - Create and configure a traversal object.
# - Execute 'next' to retrieve one path at a time,
# until the command returns False, signaling that
# the iterator has exhausted the supply of paths.
# (The path is stored in the named variable).
#
# The execution of 'next' can be done in a loop, or via event
# processing.
# (b) Basic loop
# - Create and configure a traversal object.
# - Run a script for each path, using 'foreach'.
# This is a convenient standard wrapper around 'next'.
#
# The loop properly handles all possible Tcl result codes.
# (c) Non-incremental, non-looping.
# - Create and configure a traversal object.
# - Retrieve a list of all paths via 'files'.
# The -prefilter callback is executed for directories. Its result
# determines if the traverser recurses into the directory or not.
# The default is to always recurse into all directories. The call-
# back is invoked with a single argument, the path of the
# directory.
#
# The -filter callback is executed for all paths. Its result
# determines if the current path is a valid result, and returned
# by 'next'. The default is to accept all paths as valid. The
# callback is invoked with a single argument, the path to check.
# The -errorcmd callback is executed for all paths the traverser
# has trouble with. Like being unable to cd into them, get their
# status, etc. The default is to ignore any such problems. The
# callback is invoked with a two arguments, the path for which the
# error occured, and the error message. Errors thrown by the
# filter callbacks are handled through this callback too. Errors
# thrown by the error callback itself are not caught and ignored,
# but allowed to pass to the caller, usually of 'next'.
# Note: Low-level functionality, version and platform dependent is
# implemented in procedures, and conditioally defined for optimal
# use of features, etc. ...
# Note: Traversal is done in depth-first pre-order.
# Note: The options are handled only during
# construction. Afterward they are read-only and attempts to
# modify them will cause the system to throw errors.
# ### ### ### ######### ######### #########
## Implementation
option -filter -default {} -readonly 1
option -prefilter -default {} -readonly 1
option -errorcmd -default {} -readonly 1
constructor {basedir args} {
set _base $basedir
$self configurelist $args
return
}
method files {} {
set files {}
$self foreach f {lappend files $f}
return $files
}
method foreach {fvar body} {
upvar 1 $fvar currentfile
# (Re-)initialize the traversal state on every call.
$self Init
while {[$self next currentfile]} {
set code [catch {uplevel 1 $body} result]
# decide what to do upon the return code:
#
# 0 - the body executed successfully
# 1 - the body raised an error
# 2 - the body invoked [return]
# 3 - the body invoked [break]
# 4 - the body invoked [continue]
# everything else - return and pass on the results
#
switch -exact -- $code {
0 {}
1 {
return -errorinfo [::control::ErrorInfoAsCaller uplevel foreach] \
-errorcode $::errorCode -code error $result
}
3 {
# FRINK: nocheck
return
}
4 {}
default {
return -code $code $result
}
}
}
return
}
method next {fvar} {
upvar 1 $fvar currentfile
# Initialize on first call.
if {!$_init} {
$self Init
}
# We (still) have valid paths in the result stack, return the
# next one.
if {[llength $_results]} {
set top [lindex $_results end]
set _results [lreplace $_results end end]
set currentfile $top
return 1
}
# Take the next directory waiting in the processing stack and
# fill the result stack with all valid files and sub-
# directories contained in it. Extend the processing queue
# with all sub-directories not yet seen already (!circular
# symlinks) and accepted by the prefilter. We stop iterating
# when we either have no directories to process anymore, or
# the result stack contains at least one path we can return.
while {[llength $_pending]} {
set top [lindex $_pending end]
set _pending [lreplace $_pending end end]
# Directory accessible? Skip if not.
if {![ACCESS $top]} {
Error $top "Inacessible directory"
continue
}
# Expand the result stack with all files in the directory,
# modulo filtering.
foreach f [GLOBF $top] {
if {![Valid $f]} continue
lappend _results $f
}
# Expand the result stack with all sub-directories in the
# directory, modulo filtering. Further expand the
# processing stack with the same directories, if not seen
# yet and modulo pre-filtering.
foreach f [GLOBD $top] {
if {
[string equal [file tail $f] "."] ||
[string equal [file tail $f] ".."]
} continue
if {[Valid $f]} {
lappend _results $f
}
Enter $top $f
if {[Cycle $f]} continue
if {[Recurse $f]} {
lappend _pending $f
}
}
# Stop expanding if we have paths to return.
if {[llength $_results]} {
set top [lindex $_results end]
set _results [lreplace $_results end end]
set currentfile $top
return 1
}
}
# Allow re-initialization with next call.
set _init 0
return 0
}
# ### ### ### ######### ######### #########
## Traversal state
# * Initialization flag. Checked in 'next', reset by next when no
# more files are available. Set in 'Init'.
# * Base directory (or file) to start the traversal from.
# * Stack of prefiltered unknown directories waiting for
# processing, i.e. expansion (TOP at end).
# * Stack of valid paths waiting to be returned as results.
# * Set of directories already visited (normalized paths), for
# detection of circular symbolic links.
variable _init 0 ; # Initialization flag.
variable _base {} ; # Base directory.
variable _pending {} ; # Processing stack.
variable _results {} ; # Result stack.
# sym link handling (to break cycles, while allowing the following of non-cycle links).
# Notes
# - path parent tracking is lexical.
# - path identity tracking is based on the normalized path, i.e. the path with all
# symlinks resolved.
# Maps
# - path -> parent (easier to follow the list than doing dirname's)
# - path -> normalized (cache to avoid redundant calls of fullnormalize)
# cycle <=> A parent's normalized form (NF) is identical to the current path's NF
variable _parent -array {}
variable _norm -array {}
# ### ### ### ######### ######### #########
## Internal helpers.
proc Enter {parent path} {
#puts ___E|$path
upvar 1 _parent _parent _norm _norm
set _parent($path) $parent
set _norm($path) [fileutil::fullnormalize $path]
}
proc Cycle {path} {
upvar 1 _parent _parent _norm _norm
set nform $_norm($path)
set paren $_parent($path)
while {$paren ne {}} {
if {$_norm($paren) eq $nform} { return yes }
set paren $_parent($paren)
}
return no
}
method Init {} {
array unset _parent *
array unset _norm *
# Path ok as result?
if {[Valid $_base]} {
lappend _results $_base
}
# Expansion allowed by prefilter?
if {[file isdirectory $_base] && [Recurse $_base]} {
Enter {} $_base
lappend _pending $_base
}
# System is set up now.
set _init 1
return
}
proc Valid {path} {
#puts ___V|$path
upvar 1 options options
if {![llength $options(-filter)]} {return 1}
set path [file normalize $path]
set code [catch {uplevel \#0 [linsert $options(-filter) end $path]} valid]
if {!$code} {return $valid}
Error $path $valid
return 0
}
proc Recurse {path} {
#puts ___X|$path
upvar 1 options options _norm _norm
if {![llength $options(-prefilter)]} {return 1}
set path [file normalize $path]
set code [catch {uplevel \#0 [linsert $options(-prefilter) end $path]} valid]
if {!$code} {return $valid}
Error $path $valid
return 0
}
proc Error {path msg} {
upvar 1 options options
if {![llength $options(-errorcmd)]} return
set path [file normalize $path]
uplevel \#0 [linsert $options(-errorcmd) end $path $msg]
return
}
##
# ### ### ### ######### ######### #########
}
# ### ### ### ######### ######### #########
##
# The next three helper commands for the traverser depend strongly on
# the version of Tcl, and partially on the platform.
# 1. In Tcl 8.3 using -types f will return only true files, but not
# links to files. This changed in 8.4+ where links to files are
# returned as well. So for 8.3 we have to handle the links
# separately (-types l) and also filter on our own.
# Note that Windows file links are hard links which are reported by
# -types f, but not -types l, so we can optimize that for the two
# platforms.
#
# 2. In Tcl 8.3 we also have a crashing bug in glob (SIGABRT, "stat on
# a known file") when trying to perform 'glob -types {hidden f}' on
# a directory without e'x'ecute permissions. We code around by
# testing if we can cd into the directory (stat might return enough
# information too (mode), but possibly also not portable).
#
# For Tcl 8.2 and 8.4+ glob simply delivers an empty result
# (-nocomplain), without crashing. For them this command is defined
# so that the bytecode compiler removes it from the bytecode.
#
# This bug made the ACCESS helper necessary.
# We code around the problem by testing if we can cd into the
# directory (stat might return enough information too (mode), but
# possibly also not portable).
if {[package vsatisfies [package present Tcl] 8.5]} {
# Tcl 8.5+.
# We have to check readability of "current" on our own, glob
# changed to error out instead of returning nothing.
proc ::fileutil::traverse::ACCESS {args} {return 1}
proc ::fileutil::traverse::GLOBF {current} {
if {![file readable $current] ||
[BadLink $current]} {
return {}
}
set res [lsort -unique [concat \
[glob -nocomplain -directory $current -types f -- *] \
[glob -nocomplain -directory $current -types {hidden f} -- *]]]
# Look for broken links (They are reported as neither file nor directory).
foreach l [lsort -unique [concat \
[glob -nocomplain -directory $current -types l -- *] \
[glob -nocomplain -directory $current -types {hidden l} -- *]]] {
if {[file isfile $l]} continue
if {[file isdirectory $l]} continue
lappend res $l
}
return [lsort -unique $res]
}
proc ::fileutil::traverse::GLOBD {current} {
if {![file readable $current] ||
[BadLink $current]} {
return {}
}
lsort -unique [concat \
[glob -nocomplain -directory $current -types d -- *] \
[glob -nocomplain -directory $current -types {hidden d} -- *]]
}
proc ::fileutil::traverse::BadLink {current} {
if {[file type $current] ne "link"} { return no }
set dst [file join [file dirname $current] [file readlink $current]]
if {![file exists $dst] ||
![file readable $dst]} {
return yes
}
return no
}
} elseif {[package vsatisfies [package present Tcl] 8.4]} {
# Tcl 8.4+.
# (Ad 1) We have -directory, and -types,
# (Ad 2) Links are returned for -types f/d if they refer to files/dirs.
# (Ad 3) No bug to code around
proc ::fileutil::traverse::ACCESS {args} {return 1}
proc ::fileutil::traverse::GLOBF {current} {
set res [concat \
[glob -nocomplain -directory $current -types f -- *] \
[glob -nocomplain -directory $current -types {hidden f} -- *]]
# Look for broken links (They are reported as neither file nor directory).
foreach l [concat \
[glob -nocomplain -directory $current -types l -- *] \
[glob -nocomplain -directory $current -types {hidden l} -- *] ] {
if {[file isfile $l]} continue
if {[file isdirectory $l]} continue
lappend res $l
}
return $res
}
proc ::fileutil::traverse::GLOBD {current} {
concat \
[glob -nocomplain -directory $current -types d -- *] \
[glob -nocomplain -directory $current -types {hidden d} -- *]
}
} else {
# 8.3.
# (Ad 1) We have -directory, and -types,
# (Ad 2) Links are NOT returned for -types f/d, collect separately.
# No symbolic file links on Windows.
# (Ad 3) Bug to code around.
proc ::fileutil::traverse::ACCESS {current} {
if {[catch {
set h [pwd] ; cd $current ; cd $h
}]} {return 0}
return 1
}
if {[string equal $::tcl_platform(platform) windows]} {
proc ::fileutil::traverse::GLOBF {current} {
concat \
[glob -nocomplain -directory $current -types f -- *] \
[glob -nocomplain -directory $current -types {hidden f} -- *]]
}
} else {
proc ::fileutil::traverse::GLOBF {current} {
set l [concat \
[glob -nocomplain -directory $current -types f -- *] \
[glob -nocomplain -directory $current -types {hidden f} -- *]]
foreach x [concat \
[glob -nocomplain -directory $current -types l -- *] \
[glob -nocomplain -directory $current -types {hidden l} -- *]] {
if {[file isdirectory $x]} continue
# We have now accepted files, links to files, and broken links.
lappend l $x
}
return $l
}
}
proc ::fileutil::traverse::GLOBD {current} {
set l [concat \
[glob -nocomplain -directory $current -types d -- *] \
[glob -nocomplain -directory $current -types {hidden d} -- *]]
foreach x [concat \
[glob -nocomplain -directory $current -types l -- *] \
[glob -nocomplain -directory $current -types {hidden l} -- *]] {
if {![file isdirectory $x]} continue
lappend l $x
}
return $l
}
}
# ### ### ### ######### ######### #########
## Ready
package provide fileutil::traverse 0.6

2
src/bootsupport/lib/README.md
Unescape View File

@ -0,0 +1,2 @@
This folder is for tcl packages which use the pkgIndex.tcl system to load, and are required by boot or make related scripts in src.

0
src/bootsupport/README.md → src/bootsupport/modules/README.md
Unescape View File

2
src/bootsupport/cksum-1.1.4.tm → src/bootsupport/modules/cksum-1.1.4.tm
Unescape View File

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

933
src/bootsupport/modules/cmdline-1.5.2.tm
Unescape View File

@ -0,0 +1,933 @@
# cmdline.tcl --
#
# This package provides a utility for parsing command line
# arguments that are processed by our various applications.
# It also includes a utility routine to determine the
# application name for use in command line errors.
#
# Copyright (c) 1998-2000 by Ajuba Solutions.
# Copyright (c) 2001-2015 by Andreas Kupries <andreas_kupries@users.sf.net>.
# Copyright (c) 2003 by David N. Welton <davidw@dedasys.com>
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require Tcl 8.5-
package provide cmdline 1.5.2
namespace eval ::cmdline {
namespace export getArgv0 getopt getKnownOpt getfiles getoptions \
getKnownOptions usage
}
# ::cmdline::getopt --
#
# The cmdline::getopt works in a fashion like the standard
# C based getopt function. Given an option string and a
# pointer to an array or args this command will process the
# first argument and return info on how to proceed.
#
# Arguments:
# argvVar Name of the argv list that you
# want to process. If options are found the
# arg list is modified and the processed arguments
# are removed from the start of the list.
# optstring A list of command options that the application
# will accept. If the option ends in ".arg" the
# getopt routine will use the next argument as
# an argument to the option. Otherwise the option
# is a boolean that is set to 1 if present.
# optVar The variable pointed to by optVar
# contains the option that was found (without the
# leading '-' and without the .arg extension).
# valVar Upon success, the variable pointed to by valVar
# contains the value for the specified option.
# This value comes from the command line for .arg
# options, otherwise the value is 1.
# If getopt fails, the valVar is filled with an
# error message.
#
# Results:
# The getopt function returns 1 if an option was found, 0 if no more
# options were found, and -1 if an error occurred.
proc ::cmdline::getopt {argvVar optstring optVar valVar} {
upvar 1 $argvVar argsList
upvar 1 $optVar option
upvar 1 $valVar value
set result [getKnownOpt argsList $optstring option value]
if {$result < 0} {
# Collapse unknown-option error into any-other-error result.
set result -1
}
return $result
}
# ::cmdline::getKnownOpt --
#
# The cmdline::getKnownOpt works in a fashion like the standard
# C based getopt function. Given an option string and a
# pointer to an array or args this command will process the
# first argument and return info on how to proceed.
#
# Arguments:
# argvVar Name of the argv list that you
# want to process. If options are found the
# arg list is modified and the processed arguments
# are removed from the start of the list. Note that
# unknown options and the args that follow them are
# left in this list.
# optstring A list of command options that the application
# will accept. If the option ends in ".arg" the
# getopt routine will use the next argument as
# an argument to the option. Otherwise the option
# is a boolean that is set to 1 if present.
# optVar The variable pointed to by optVar
# contains the option that was found (without the
# leading '-' and without the .arg extension).
# valVar Upon success, the variable pointed to by valVar
# contains the value for the specified option.
# This value comes from the command line for .arg
# options, otherwise the value is 1.
# If getopt fails, the valVar is filled with an
# error message.
#
# Results:
# The getKnownOpt function returns 1 if an option was found,
# 0 if no more options were found, -1 if an unknown option was
# encountered, and -2 if any other error occurred.
proc ::cmdline::getKnownOpt {argvVar optstring optVar valVar} {
upvar 1 $argvVar argsList
upvar 1 $optVar option
upvar 1 $valVar value
# default settings for a normal return
set value ""
set option ""
set result 0
# check if we're past the end of the args list
if {[llength $argsList] != 0} {
# if we got -- or an option that doesn't begin with -, return (skipping
# the --). otherwise process the option arg.
switch -glob -- [set arg [lindex $argsList 0]] {
"--" {
set argsList [lrange $argsList 1 end]
}
"--*" -
"-*" {
set option [string range $arg 1 end]
if {[string equal [string range $option 0 0] "-"]} {
set option [string range $arg 2 end]
}
# support for format: [-]-option=value
set idx [string first "=" $option 1]
if {$idx != -1} {
set _val [string range $option [expr {$idx+1}] end]
set option [string range $option 0 [expr {$idx-1}]]
}
if {[lsearch -exact $optstring $option] != -1} {
# Booleans are set to 1 when present
set value 1
set result 1
set argsList [lrange $argsList 1 end]
} elseif {[lsearch -exact $optstring "$option.arg"] != -1} {
set result 1
set argsList [lrange $argsList 1 end]
if {[info exists _val]} {
set value $_val
} elseif {[llength $argsList]} {
set value [lindex $argsList 0]
set argsList [lrange $argsList 1 end]
} else {
set value "Option \"$option\" requires an argument"
set result -2
}
} else {
# Unknown option.
set value "Illegal option \"-$option\""
set result -1
}
}
default {
# Skip ahead
}
}
}
return $result
}
# ::cmdline::getoptions --
#
# Process a set of command line options, filling in defaults
# for those not specified. This also generates an error message
# that lists the allowed flags if an incorrect flag is specified.
#
# Arguments:
# argvVar The name of the argument list, typically argv.
# We remove all known options and their args from it.
# In other words, after the call to this command the
# referenced variable contains only the non-options,
# and unknown options.
# optlist A list-of-lists where each element specifies an option
# in the form:
# (where flag takes no argument)
# flag comment
#
# (or where flag takes an argument)
# flag default comment
#
# If flag ends in ".arg" then the value is taken from the
# command line. Otherwise it is a boolean and appears in
# the result if present on the command line. If flag ends
# in ".secret", it will not be displayed in the usage.
# usage Text to include in the usage display. Defaults to
# "options:"
#
# Results
# Name value pairs suitable for using with array set.
# A modified `argvVar`.
proc ::cmdline::getoptions {argvVar optlist {usage options:}} {
upvar 1 $argvVar argv
set opts [GetOptionDefaults $optlist result]
set argc [llength $argv]
while {[set err [getopt argv $opts opt arg]]} {
if {$err < 0} {
set result(?) ""
break
}
set result($opt) $arg
}
if {[info exist result(?)] || [info exists result(help)]} {
Error [usage $optlist $usage] USAGE
}
return [array get result]
}
# ::cmdline::getKnownOptions --
#
# Process a set of command line options, filling in defaults
# for those not specified. This ignores unknown flags, but generates
# an error message that lists the correct usage if a known option
# is used incorrectly.
#
# Arguments:
# argvVar The name of the argument list, typically argv. This
# We remove all known options and their args from it.
# In other words, after the call to this command the
# referenced variable contains only the non-options,
# and unknown options.
# optlist A list-of-lists where each element specifies an option
# in the form:
# flag default comment
# If flag ends in ".arg" then the value is taken from the
# command line. Otherwise it is a boolean and appears in
# the result if present on the command line. If flag ends
# in ".secret", it will not be displayed in the usage.
# usage Text to include in the usage display. Defaults to
# "options:"
#
# Results
# Name value pairs suitable for using with array set.
# A modified `argvVar`.
proc ::cmdline::getKnownOptions {argvVar optlist {usage options:}} {
upvar 1 $argvVar argv
set opts [GetOptionDefaults $optlist result]
# As we encounter them, keep the unknown options and their
# arguments in this list. Before we return from this procedure,
# we'll prepend these args to the argList so that the application
# doesn't lose them.
set unknownOptions [list]
set argc [llength $argv]
while {[set err [getKnownOpt argv $opts opt arg]]} {
if {$err == -1} {
# Unknown option.
# Skip over any non-option items that follow it.
# For now, add them to the list of unknownOptions.
lappend unknownOptions [lindex $argv 0]
set argv [lrange $argv 1 end]
while {([llength $argv] != 0) \
&& ![string match "-*" [lindex $argv 0]]} {
lappend unknownOptions [lindex $argv 0]
set argv [lrange $argv 1 end]
}
} elseif {$err == -2} {
set result(?) ""
break
} else {
set result($opt) $arg
}
}
# Before returning, prepend the any unknown args back onto the
# argList so that the application doesn't lose them.
set argv [concat $unknownOptions $argv]
if {[info exist result(?)] || [info exists result(help)]} {
Error [usage $optlist $usage] USAGE
}
return [array get result]
}
# ::cmdline::GetOptionDefaults --
#
# This internal procedure processes the option list (that was passed to
# the getopt or getKnownOpt procedure). The defaultArray gets an index
# for each option in the option list, the value of which is the option's
# default value.
#
# Arguments:
# optlist A list-of-lists where each element specifies an option
# in the form:
# flag default comment
# If flag ends in ".arg" then the value is taken from the
# command line. Otherwise it is a boolean and appears in
# the result if present on the command line. If flag ends
# in ".secret", it will not be displayed in the usage.
# defaultArrayVar The name of the array in which to put argument defaults.
#
# Results
# Name value pairs suitable for using with array set.
proc ::cmdline::GetOptionDefaults {optlist defaultArrayVar} {
upvar 1 $defaultArrayVar result
set opts {? help}
foreach opt $optlist {
set name [lindex $opt 0]
if {[regsub -- {\.secret$} $name {} name] == 1} {
# Need to hide this from the usage display and getopt
}
lappend opts $name
if {[regsub -- {\.arg$} $name {} name] == 1} {
# Set defaults for those that take values.
set default [lindex $opt 1]
set result($name) $default
} else {
# The default for booleans is false
set result($name) 0
}
}
return $opts
}
# ::cmdline::usage --
#
# Generate an error message that lists the allowed flags.
#
# Arguments:
# optlist As for cmdline::getoptions
# usage Text to include in the usage display. Defaults to
# "options:"
#
# Results
# A formatted usage message
proc ::cmdline::usage {optlist {usage {options:}}} {
set str "[getArgv0] $usage\n"
set longest 20
set lines {}
foreach opt [concat $optlist \
{{- "Forcibly stop option processing"} {help "Print this message"} {? "Print this message"}}] {
set name "-[lindex $opt 0]"
if {[regsub -- {\.secret$} $name {} name] == 1} {
# Hidden option
continue
}
if {[regsub -- {\.arg$} $name {} name] == 1} {
append name " value"
set desc "[lindex $opt 2] <[lindex $opt 1]>"
} else {
set desc "[lindex $opt 1]"
}
set n [string length $name]
if {$n > $longest} { set longest $n }
# max not available before 8.5 - set longest [expr {max($longest, )}]
lappend lines $name $desc
}
foreach {name desc} $lines {
append str "[string trimright [format " %-*s %s" $longest $name $desc]]\n"
}
return $str
}
# ::cmdline::getfiles --
#
# Given a list of file arguments from the command line, compute
# the set of valid files. On windows, file globbing is performed
# on each argument. On Unix, only file existence is tested. If
# a file argument produces no valid files, a warning is optionally
# generated.
#
# This code also uses the full path for each file. If not
# given it prepends [pwd] to the filename. This ensures that
# these files will never conflict with files in our zip file.
#
# Arguments:
# patterns The file patterns specified by the user.
# quiet If this flag is set, no warnings will be generated.
#
# Results:
# Returns the list of files that match the input patterns.
proc ::cmdline::getfiles {patterns quiet} {
set result {}
if {$::tcl_platform(platform) == "windows"} {
foreach pattern $patterns {
set pat [file join $pattern]
set files [glob -nocomplain -- $pat]
if {$files == {}} {
if {! $quiet} {
puts stdout "warning: no files match \"$pattern\""
}
} else {
foreach file $files {
lappend result $file
}
}
}
} else {
set result $patterns
}
set files {}
foreach file $result {
# Make file an absolute path so that we will never conflict
# with files that might be contained in our zip file.
set fullPath [file join [pwd] $file]
if {[file isfile $fullPath]} {
lappend files $fullPath
} elseif {! $quiet} {
puts stdout "warning: no files match \"$file\""
}
}
return $files
}
# ::cmdline::getArgv0 --
#
# This command returns the "sanitized" version of argv0. It will strip
# off the leading path and remove the ".bin" extensions that our apps
# use because they must be wrapped by a shell script.
#
# Arguments:
# None.
#
# Results:
# The application name that can be used in error messages.
proc ::cmdline::getArgv0 {} {
global argv0
set name [file tail $argv0]
return [file rootname $name]
}
##
# ### ### ### ######### ######### #########
##
# Now the typed versions of the above commands.
##
# ### ### ### ######### ######### #########
##
# typedCmdline.tcl --
#
# This package provides a utility for parsing typed command
# line arguments that may be processed by various applications.
#
# Copyright (c) 2000 by Ross Palmer Mohn.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: cmdline.tcl,v 1.28 2011/02/23 17:41:52 andreas_kupries Exp $
namespace eval ::cmdline {
namespace export typedGetopt typedGetoptions typedUsage
# variable cmdline::charclasses --
#
# Create regexp list of allowable character classes
# from "string is" error message.
#
# Results:
# String of character class names separated by "|" characters.
variable charclasses
#checker exclude badKey
catch {string is . .} charclasses
variable dummy
regexp -- {must be (.+)$} $charclasses dummy charclasses
regsub -all -- {, (or )?} $charclasses {|} charclasses
unset dummy
}
# ::cmdline::typedGetopt --
#
# The cmdline::typedGetopt works in a fashion like the standard
# C based getopt function. Given an option string and a
# pointer to a list of args this command will process the
# first argument and return info on how to proceed. In addition,
# you may specify a type for the argument to each option.
#
# Arguments:
# argvVar Name of the argv list that you want to process.
# If options are found, the arg list is modified
# and the processed arguments are removed from the
# start of the list.
#
# optstring A list of command options that the application
# will accept. If the option ends in ".xxx", where
# xxx is any valid character class to the tcl
# command "string is", then typedGetopt routine will
# use the next argument as a typed argument to the
# option. The argument must match the specified
# character classes (e.g. integer, double, boolean,
# xdigit, etc.). Alternatively, you may specify
# ".arg" for an untyped argument.
#
# optVar Upon success, the variable pointed to by optVar
# contains the option that was found (without the
# leading '-' and without the .xxx extension). If
# typedGetopt fails the variable is set to the empty
# string. SOMETIMES! Different for each -value!
#
# argVar Upon success, the variable pointed to by argVar
# contains the argument for the specified option.
# If typedGetopt fails, the variable is filled with
# an error message.
#
# Argument type syntax:
# Option that takes no argument.
# foo
#
# Option that takes a typeless argument.
# foo.arg
#
# Option that takes a typed argument. Allowable types are all
# valid character classes to the tcl command "string is".
# Currently must be one of alnum, alpha, ascii, control,
# boolean, digit, double, false, graph, integer, lower, print,
# punct, space, true, upper, wordchar, or xdigit.
# foo.double
#
# Option that takes an argument from a list.
# foo.(bar|blat)
#
# Argument quantifier syntax:
# Option that takes an optional argument.
# foo.arg?
#
# Option that takes a list of arguments terminated by "--".
# foo.arg+
#
# Option that takes an optional list of arguments terminated by "--".
# foo.arg*
#
# Argument quantifiers work on all argument types, so, for
# example, the following is a valid option specification.
# foo.(bar|blat|blah)?
#
# Argument syntax miscellany:
# Options may be specified on the command line using a unique,
# shortened version of the option name. Given that program foo
# has an option list of {bar.alpha blah.arg blat.double},
# "foo -b fob" returns an error, but "foo -ba fob"
# successfully returns {bar fob}
#
# Results:
# The typedGetopt function returns one of the following:
# 1 a valid option was found
# 0 no more options found to process
# -1 invalid option
# -2 missing argument to a valid option
# -3 argument to a valid option does not match type
#
# Known Bugs:
# When using options which include special glob characters,
# you must use the exact option. Abbreviating it can cause
# an error in the "cmdline::prefixSearch" procedure.
proc ::cmdline::typedGetopt {argvVar optstring optVar argVar} {
variable charclasses
upvar $argvVar argsList
upvar $optVar retvar
upvar $argVar optarg
# default settings for a normal return
set optarg ""
set retvar ""
set retval 0
# check if we're past the end of the args list
if {[llength $argsList] != 0} {
# if we got -- or an option that doesn't begin with -, return (skipping
# the --). otherwise process the option arg.
switch -glob -- [set arg [lindex $argsList 0]] {
"--" {
set argsList [lrange $argsList 1 end]
}
"-*" {
# Create list of options without their argument extensions
set optstr ""
foreach str $optstring {
lappend optstr [file rootname $str]
}
set _opt [string range $arg 1 end]
set i [prefixSearch $optstr [file rootname $_opt]]
if {$i != -1} {
set opt [lindex $optstring $i]
set quantifier "none"
if {[regexp -- {\.[^.]+([?+*])$} $opt dummy quantifier]} {
set opt [string range $opt 0 end-1]
}
if {[string first . $opt] == -1} {
set retval 1
set retvar $opt
set argsList [lrange $argsList 1 end]
} elseif {[regexp -- "\\.(arg|$charclasses)\$" $opt dummy charclass]
|| [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]} {
if {[string equal arg $charclass]} {
set type arg
} elseif {[regexp -- "^($charclasses)\$" $charclass]} {
set type class
} else {
set type oneof
}
set argsList [lrange $argsList 1 end]
set opt [file rootname $opt]
while {1} {
if {[llength $argsList] == 0
|| [string equal "--" [lindex $argsList 0]]} {
if {[string equal "--" [lindex $argsList 0]]} {
set argsList [lrange $argsList 1 end]
}
set oneof ""
if {$type == "arg"} {
set charclass an
} elseif {$type == "oneof"} {
set oneof ", one of $charclass"
set charclass an
}
if {$quantifier == "?"} {
set retval 1
set retvar $opt
set optarg ""
} elseif {$quantifier == "+"} {
set retvar $opt
if {[llength $optarg] < 1} {
set retval -2
set optarg "Option requires at least one $charclass argument$oneof -- $opt"
} else {
set retval 1
}
} elseif {$quantifier == "*"} {
set retval 1
set retvar $opt
} else {
set optarg "Option requires $charclass argument$oneof -- $opt"
set retvar $opt
set retval -2
}
set quantifier ""
} elseif {($type == "arg")
|| (($type == "oneof")
&& [string first "|[lindex $argsList 0]|" "|$charclass|"] != -1)
|| (($type == "class")
&& [string is $charclass [lindex $argsList 0]])} {
set retval 1
set retvar $opt
lappend optarg [lindex $argsList 0]
set argsList [lrange $argsList 1 end]
} else {
set oneof ""
if {$type == "arg"} {
set charclass an
} elseif {$type == "oneof"} {
set oneof ", one of $charclass"
set charclass an
}
set optarg "Option requires $charclass argument$oneof -- $opt"
set retvar $opt
set retval -3
if {$quantifier == "?"} {
set retval 1
set optarg ""
}
set quantifier ""
}
if {![regexp -- {[+*]} $quantifier]} {
break;
}
}
} else {
Error \
"Illegal option type specification: must be one of $charclasses" \
BAD OPTION TYPE
}
} else {
set optarg "Illegal option -- $_opt"
set retvar $_opt
set retval -1
}
}
default {
# Skip ahead
}
}
}
return $retval
}
# ::cmdline::typedGetoptions --
#
# Process a set of command line options, filling in defaults
# for those not specified. This also generates an error message
# that lists the allowed options if an incorrect option is
# specified.
#
# Arguments:
# argvVar The name of the argument list, typically argv
# optlist A list-of-lists where each element specifies an option
# in the form:
#
# option default comment
#
# Options formatting is as described for the optstring
# argument of typedGetopt. Default is for optionally
# specifying a default value. Comment is for optionally
# specifying a comment for the usage display. The
# options "--", "-help", and "-?" are automatically included
# in optlist.
#
# Argument syntax miscellany:
# Options formatting and syntax is as described in typedGetopt.
# There are two additional suffixes that may be applied when
# passing options to typedGetoptions.
#
# You may add ".multi" as a suffix to any option. For options
# that take an argument, this means that the option may be used
# more than once on the command line and that each additional
# argument will be appended to a list, which is then returned
# to the application.
# foo.double.multi
#
# If a non-argument option is specified as ".multi", it is
# toggled on and off for each time it is used on the command
# line.
# foo.multi
#
# If an option specification does not contain the ".multi"
# suffix, it is not an error to use an option more than once.
# In this case, the behavior for options with arguments is that
# the last argument is the one that will be returned. For
# options that do not take arguments, using them more than once
# has no additional effect.
#
# Options may also be hidden from the usage display by
# appending the suffix ".secret" to any option specification.
# Please note that the ".secret" suffix must be the last suffix,
# after any argument type specification and ".multi" suffix.
# foo.xdigit.multi.secret
#
# Results
# Name value pairs suitable for using with array set.
proc ::cmdline::typedGetoptions {argvVar optlist {usage options:}} {
variable charclasses
upvar 1 $argvVar argv
set opts {? help}
foreach opt $optlist {
set name [lindex $opt 0]
if {[regsub -- {\.secret$} $name {} name] == 1} {
# Remove this extension before passing to typedGetopt.
}
if {[regsub -- {\.multi$} $name {} name] == 1} {
# Remove this extension before passing to typedGetopt.
regsub -- {\..*$} $name {} temp
set multi($temp) 1
}
lappend opts $name
if {[regsub -- "\\.(arg|$charclasses|\\(.+).?\$" $name {} name] == 1} {
# Set defaults for those that take values.
# Booleans are set just by being present, or not
set dflt [lindex $opt 1]
if {$dflt != {}} {
set defaults($name) $dflt
}
}
}
set argc [llength $argv]
while {[set err [typedGetopt argv $opts opt arg]]} {
if {$err == 1} {
if {[info exists result($opt)]
&& [info exists multi($opt)]} {
# Toggle boolean options or append new arguments
if {$arg == ""} {
unset result($opt)
} else {
set result($opt) "$result($opt) $arg"
}
} else {
set result($opt) "$arg"
}
} elseif {($err == -1) || ($err == -3)} {
Error [typedUsage $optlist $usage] USAGE
} elseif {$err == -2 && ![info exists defaults($opt)]} {
Error [typedUsage $optlist $usage] USAGE
}
}
if {[info exists result(?)] || [info exists result(help)]} {
Error [typedUsage $optlist $usage] USAGE
}
foreach {opt dflt} [array get defaults] {
if {![info exists result($opt)]} {
set result($opt) $dflt
}
}
return [array get result]
}
# ::cmdline::typedUsage --
#
# Generate an error message that lists the allowed flags,
# type of argument taken (if any), default value (if any),
# and an optional description.
#
# Arguments:
# optlist As for cmdline::typedGetoptions
#
# Results
# A formatted usage message
proc ::cmdline::typedUsage {optlist {usage {options:}}} {
variable charclasses
set str "[getArgv0] $usage\n"
set longest 20
set lines {}
foreach opt [concat $optlist \
{{help "Print this message"} {? "Print this message"}}] {
set name "-[lindex $opt 0]"
if {[regsub -- {\.secret$} $name {} name] == 1} {
# Hidden option
continue
}
if {[regsub -- {\.multi$} $name {} name] == 1} {
# Display something about multiple options
}
if {[regexp -- "\\.(arg|$charclasses)\$" $name dummy charclass] ||
[regexp -- {\.\(([^)]+)\)} $opt dummy charclass]
} {
regsub -- "\\..+\$" $name {} name
append name " $charclass"
set desc [lindex $opt 2]
set default [lindex $opt 1]
if {$default != ""} {
append desc " <$default>"
}
} else {
set desc [lindex $opt 1]
}
lappend accum $name $desc
set n [string length $name]
if {$n > $longest} { set longest $n }
# max not available before 8.5 - set longest [expr {max($longest, [string length $name])}]
}
foreach {name desc} $accum {
append str "[string trimright [format " %-*s %s" $longest $name $desc]]\n"
}
return $str
}
# ::cmdline::prefixSearch --
#
# Search a Tcl list for a pattern; searches first for an exact match,
# and if that fails, for a unique prefix that matches the pattern
# (i.e, first "lsearch -exact", then "lsearch -glob $pattern*"
#
# Arguments:
# list list of words
# pattern word to search for
#
# Results:
# Index of found word is returned. If no exact match or
# unique short version is found then -1 is returned.
proc ::cmdline::prefixSearch {list pattern} {
# Check for an exact match
if {[set pos [::lsearch -exact $list $pattern]] > -1} {
return $pos
}
# Check for a unique short version
set slist [lsort $list]
if {[set pos [::lsearch -glob $slist $pattern*]] > -1} {
# What if there is nothing for the check variable?
set check [lindex $slist [expr {$pos + 1}]]
if {[string first $pattern $check] != 0} {
return [::lsearch -exact $list [lindex $slist $pos]]
}
}
return -1
}
# ::cmdline::Error --
#
# Internal helper to throw errors with a proper error-code attached.
#
# Arguments:
# message text of the error message to throw.
# args additional parts of the error code to use,
# with CMDLINE as basic prefix added by this command.
#
# Results:
# An error is thrown, always.
proc ::cmdline::Error {message args} {
return -code error -errorcode [linsert $args 0 CMDLINE] $message
}

2
src/bootsupport/fileutil-1.16.1.tm → src/bootsupport/modules/fileutil-1.16.1.tm
Unescape View File

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

52
src/bootsupport/punk/du-0.1.0.tm → src/bootsupport/modules/punk/du-0.1.0.tm
Unescape View File

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

123
src/bootsupport/punk/mix-0.2.tm → src/bootsupport/modules/punk/mix-0.2.tm
Unescape View File

@ -286,13 +286,15 @@ namespace eval punk::mix::cli {
}
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 <projectdir>/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]} {

0
src/bootsupport/punk/repo-0.1.0.tm → src/bootsupport/modules/punk/repo-0.1.0.tm
Unescape View File

0
src/bootsupport/punk/winpath-0.1.0.tm → src/bootsupport/modules/punk/winpath-0.1.0.tm
Unescape View File

189
src/bootsupport/modules/struct/set-2.2.3.tm
Unescape View File

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

189
src/bootsupport/modules/struct/sets.tcl
Unescape View File

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

93
src/bootsupport/modules/struct/sets_c.tcl
Unescape View File

@ -0,0 +1,93 @@
#----------------------------------------------------------------------
#
# sets_tcl.tcl --
#
# Definitions for the processing of sets. C implementation.
#
# Copyright (c) 2007 by Andreas Kupries.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: sets_c.tcl,v 1.3 2008/03/25 07:15:34 andreas_kupries Exp $
#
#----------------------------------------------------------------------
package require critcl
# @sak notprovided struct_setc
package provide struct_setc 2.1.1
package require Tcl 8.5-
namespace eval ::struct {
# Supporting code for the main command.
catch {
#critcl::cheaders -g
#critcl::debug memory symbols
}
critcl::cheaders sets/*.h
critcl::csources sets/*.c
critcl::ccode {
/* -*- c -*- */
#include <m.h>
}
# Main command, set creation.
critcl::ccommand set_critcl {dummy interp objc objv} {
/* Syntax - dispatcher to the sub commands.
*/
static CONST char* methods [] = {
"add", "contains", "difference", "empty",
"equal","exclude", "include", "intersect",
"intersect3", "size", "subsetof", "subtract",
"symdiff", "union",
NULL
};
enum methods {
S_add, S_contains, S_difference, S_empty,
S_equal,S_exclude, S_include, S_intersect,
S_intersect3, S_size, S_subsetof, S_subtract,
S_symdiff, S_union
};
int m;
if (objc < 2) {
Tcl_WrongNumArgs (interp, objc, objv, "cmd ?arg ...?");
return TCL_ERROR;
} else if (Tcl_GetIndexFromObj (interp, objv [1], methods, "option",
0, &m) != TCL_OK) {
return TCL_ERROR;
}
/* Dispatch to methods. They check the #args in detail before performing
* the requested functionality
*/
switch (m) {
case S_add: return sm_ADD (NULL, interp, objc, objv);
case S_contains: return sm_CONTAINS (NULL, interp, objc, objv);
case S_difference: return sm_DIFFERENCE (NULL, interp, objc, objv);
case S_empty: return sm_EMPTY (NULL, interp, objc, objv);
case S_equal: return sm_EQUAL (NULL, interp, objc, objv);
case S_exclude: return sm_EXCLUDE (NULL, interp, objc, objv);
case S_include: return sm_INCLUDE (NULL, interp, objc, objv);
case S_intersect: return sm_INTERSECT (NULL, interp, objc, objv);
case S_intersect3: return sm_INTERSECT3 (NULL, interp, objc, objv);
case S_size: return sm_SIZE (NULL, interp, objc, objv);
case S_subsetof: return sm_SUBSETOF (NULL, interp, objc, objv);
case S_subtract: return sm_SUBTRACT (NULL, interp, objc, objv);
case S_symdiff: return sm_SYMDIFF (NULL, interp, objc, objv);
case S_union: return sm_UNION (NULL, interp, objc, objv);
}
/* Not coming to this place */
}
}
# ### ### ### ######### ######### #########
## Ready

452
src/bootsupport/modules/struct/sets_tcl.tcl
Unescape View File

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

275
src/build.cmd
Unescape View File

@ -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-payload>
# -*- 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
#</tcl-payload>
# -- --- --- --- --- --- --- --- --- --- --- ---
# -- 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"
#<shell-payload-pre-tcl>
#</shell-payload-pre-tcl>
# -- --- --- --- --- --- --- ---
#<shell-launch-tcl>
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
#</shell-launch-tcl>
# -- --- --- --- --- --- --- ---
#<shell-payload-post-tcl>
#</shell-payload-post-tcl>
#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
# -- --- --- ---
#<powershell-payload-pre-tcl>
#</powershell-payload-pre-tcl>
# -- --- --- --- --- --- --- ---
#<powershell-launch-tcl>
tclsh $scriptname $args
#</powershell-launch-tcl>
# -- --- --- --- --- --- --- ---
#<powershell-payload-post-tcl>
#</powershell-payload-post-tcl>
# 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
# <ctrl-z>

# </ctrl-z>
# -- unreachable by tcl directly if ctrl-z character is in the <ctrl-z> 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)
#>

32
src/make.tcl
Unescape View File

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

63
src/modules/anyname-0.2.tm
Unescape View File

@ -0,0 +1,63 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2023
#
# @@ Meta Begin
# Application tcl9test 999999.0a1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
foreach base [tcl::tm::list] {
set nsprefix "";#in case sourced directly and not in any of the .tm paths
if {[string match -nocase ${base}* [info script]]} {
set nsprefix [string trimleft [join [lrange [file split [string range [info script] [string length $base]+1 end]] 0 end-1] ::]:: ::]
break
}
}
namespace eval [lassign [split [file rootname [file tail [info script] ]] -] pkgtail verparts]${nsprefix}$pkgtail {
#--------------------------------------
#Do not put any 'package require' statements above this block. (globals nsprefix,pkgtail,verparts still set)
variable pkg "${::nsprefix}${::pkgtail}[unset ::nsprefix; unset ::pkgtail]"
variable version [join $::verparts -][unset ::verparts]
#--------------------------------------
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
##e.g package require frobz
puts stdout "-->[info script]"
puts stdout "-->[namespace current]"
puts stdout "-->pkg $pkg"
puts stdout "-->version $version"
#<tcl-payload>
#</tcl-payload>
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
uplevel #0 [list package provide $pkg $version]
}
return
#package provide tcl9test [namespace eval tcl9test {
# variable version
# set version 999999.0a1.0
#}]
#return

10
src/modules/flagfilter-0.3.tm
Unescape View File

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

57
src/modules/punk-0.1.tm
Unescape View File

@ -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 ** <i|
#straight apply approx 30x faster
#alias gmean2 apply {args {expr [tcl::mathop::* {*}$args] ** [expr 1.0/[llength $args]]}}
#know is critical to the punk repl for proper display output
interp alias {} know {} punk::know
interp alias {} know? {} punk::know?
@ -7365,5 +7384,11 @@ package require punk::mix
punk::mix::cli set_alias pmix
package provide punk [namespace eval punk {
#FUNCTL
variable version
set version 0.1
}]

116
src/modules/punk/du-999999.0a1.0.tm
Unescape View File

@ -35,7 +35,7 @@ if {"windows" eq $::tcl_platform(platform)} {
namespace eval punk::du {
proc dirlisting {{folderpath {}}} {
proc dirlisting {folderpath {glob *}} {
if {[lib::pathcharacterlen $folderpath] == 0} {
set folderpath [pwd]
} elseif {[file pathtype $folderpath] ne "absolute"} {
@ -44,7 +44,7 @@ namespace eval punk::du {
}
#run whichever of du_dirlisting_twapi, du_dirlisting_generic, du_dirlisting_unix has been activated
set dirinfo [active::du_dirlisting $folderpath]
set dirinfo [active::du_dirlisting $folderpath $glob]
}
@ -414,14 +414,55 @@ 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
dict set result -raw $iteminfo
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)
proc du_dirlisting_twapi {folderpath} {
proc du_dirlisting_twapi {folderpath {glob *}} {
set altname "" ;#possible we have to use a different name e.g short windows name or dos-device path //?/
# return it so it can be stored and tried as an alternative for problem paths
try {
set iterator [twapi::find_file_open [file join $folderpath *] -detail basic] ;# -detail full only adds data to the altname field
#glob of * will return dotfiles too on windows
set iterator [twapi::find_file_open [file join $folderpath $glob] -detail basic] ;# -detail full only adds data to the altname field
} on error args {
try {
if {[string match "*denied*" $args]} {
@ -436,7 +477,18 @@ namespace eval punk::du {
}
#errorcode TWAPI_WIN32 2 {The system cannot find the file specified.}
#This can be a perfectly normal failure to match the glob.. which means we shouldn't really warn or error
#The find-all glob * won't get here because it returns . & ..
#so we should return immediately only if the glob has globchars ? or * but isn't equal to just "*" ? (review)
#Note that windows glob ? seems to return more than just single char results - it includes .. - which differs to tcl glob
#also ???? seems to returns items 4 or less - not just items exactly 4 long (review - where is this documented?)
if {$glob ne "*" && [regexp {[?*]} $glob]} {
if {[string match "*TWAPI_WIN32 2 *" $::errorCode]} {
#looks like an ordinary no results for chosen glob
return [list dirs {} vfsmounts {} links {} files {} filesizes {} flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {}]
}
}
if {[set plen [pathcharacterlen $folderpath]] >= 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,6 +663,10 @@ 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 - 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} * .*]
@ -618,6 +682,16 @@ namespace eval punk::du {
#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} $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} $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} {
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} {
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

608
src/modules/punk/mix-0.2.tm
Unescape View File

@ -286,13 +286,15 @@ namespace eval punk::mix::cli {
}
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 <projectdir>/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,38 +434,197 @@ 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 <lib> <ver>; more stuff" from "package require <lib> 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 <pkg> <ver>
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 <pkg> <ver>
#or package require <pkg> <ver> ?<ver>?...
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]} {
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]} {
@ -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]
}
#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]
if {[file type $filepath] ne "file"} {
error "wrap_in_multishell: only script files can be wrapped."
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 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"
#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 output_file [file rootname $filepath].cmd
if {[file exists $output_file]} {
error "wrap_in_multishell: target file $output_file already exists.. aborting"
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 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
}
}
}
set startdir [pwd]
set workroot [punk::repo::find_candidate $startdir]
set wrapper_template $workroot/src/
} 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 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]
}
set tpldir [lib::mix_templates_dir]
set wrapper_template $tpldir/utility/multishell.cmd
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 <ext-payload> 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 <tagname>
# @REM # etc < blah # <tagname> etc
#---
#fix - we should use a regexp on at least <tagname> </tagname> <tagname/> 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#<something>\n ...\n#</something> 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 #<xxx/> 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" & :: #<batch-nextshell-line/>
#The .wrapconfig might contain
# tag <batch-nextshell-line> line {@set "nextshell=tclsh" & :: @<batch-nextshell-line/>}
#
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,10 +1312,15 @@ 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]
@ -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
}

13
src/modules/punk/mix/templates/layouts/project/README.md
Unescape View File

@ -0,0 +1,13 @@
%project%
==============================
+
+
About
------------------------------
+
+
+

0
src/modules/punk/mix/templates/layouts/project/src/bootsupport/README.md → src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/README.md
Unescape View File

85
src/modules/punk/mix/templates/layouts/project/src/make.tcl
Unescape View File

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

99
src/modules/punk/mix/templates/layouts/project/src/scriptapps/wrappers/README.md
Unescape View File

@ -0,0 +1,99 @@
These wrappers are intended to be used with the pmix wrapper functions to automate wrapping of tcl,sh,powershell scripts into a polyglot script which will run in multiple environments
You may also use these to hand-craft polyglot scripts.
To override the default wrapper provided by the pmix command - you can create copies of the sample_ files and remove just the sample_ part
pmix wrap will then never wrap with latest version from the punk project - but only what you have in your scriptapps/wrappers folder.
Alternatively you can copy the sample_ files and name them anything you like that doesn't begin with "punk-"
Then you can call the pmix wrap functions with the -template option and just the name of your file.
(only the scriptapps/wrappers folder will be used to locate your template)
You can create a yourscriptname.wrapconf file in the scriptapps folder alongside yourscriptname.tcl, yourscriptname.sh etc
This .wrapconf is only required if you need to do more complex wrapping.
By default, with no yourscriptname.wrapconf found:
yourscriptname.tcl will be substituted between
#<tcl-payload>
#</tcl-payload>
yourscriptname.sh (if present) will be substituted between
#<shell-payload-pre-tcl>
#</shell-payload-pre-tcl>
yourscriptname.ps1 (if present) will be substituted between
#<powershell-payload-pre-tcl>
#</powershell-payload-pre-tcl>
By providing a yourscriptname.wrapconf
you can specify the exact names of the files (in the scriptapps folder) that you want to include - and use more tags such as:
#<shell-launch-tcl>
#</shell-launch-tcl>
#<shell-payload-post-tcl>
#</shell-payload-post-tcl>
#<powershell-launch-tcl>
#/<powershell-launch-tcl>
#<powershell-payload-post-tcl>
#</powershell-payload-post-tcl>
The .wrapconf file can have comment lines (beginning with # and possibly whitespace)
e.g myutility.wrapconf might contain:
#------------------------
tagdata <shell-payload-pre-tcl> file myutility_download-tclkit2.sh
tagdata <shell-payload-pre-tcl> line {# code to verify download follows}
tagdata <shell-payload-pre-tcl> file myutility_download-tclkit2_verification.sh
tagdata <shell-launch-tcl> file myutility_launch-with-tclkit2.sh
tagdata <powershell-payload-pre-tcl> file myutility_download-tclkit2.ps1
tagdata <powershell-launch-tcl> file myutility_launch-with-tclkit2.ps1
#------------------------
Where tagdata command uses the specified file contents to replace all the lines between the starting tag and corresponding closing tag
tagdata can be called multiple times per tag and each file/line is appended to the substitution lines for that tag
It is an error to use the tagdata command on a self-closing tag (aka 'singleton' tag - such as <tag/> vs a paired set <tag> .. </tag>
paired tags must have their opening and closing tags on different lines.
hence the following line is invalid.
# <mytag> something etc </mytag> # etc
This is because system is designed to allow repeated updates and analysis of existing output files.
i.e Tags are only supported in places where the languages will accept/ignore them (generally as part of comments)
This means it should be possible to reliably detect which template was used and when template upgrades/fixes can be safely applied in the presence of possibly tweaked non-template script data.
Possible exceptions are cases where 2 templates differ only in the default data on singleton-tag lines or default data between paired tags, and that default data has been replaced.
There are of course other more flexible/standard methods (e.g diff) to achieve this sort of thing - but this method was chosen to provide more explicit readability of where the insertion points are.
singleton or paired tags can be replaced.
Failing to include the tag in the resultant line results in an error.
tagline can only be called once per tagname (e.g once for opening <tag> and once for closing </tag> or just once for self-closing tag <tag/>)
#------------------------
#replacement of a singleton tag
tagline <batch-nextshell-line/> line {@set "nextshell=tclsh" & :: @<batch-nextshell-line/>}
#replacement of closing tag of a paired-tag
tagline </powershell-launch-tcl> line {#</powershell-launch-tcl> some comment or data}
#------------------------
The .wrapconf could also specify a specific template in your scriptapps/wrappers folder e.g:
#------------------------
template myutility-multishell.cmd
#------------------------
Leave template line out, or specify the defaults if you want to use the wrappers from the punk shell you are using. e.g
#------------------------
template punk-multishell.cmd
#------------------------

0
src/modules/punk/mix/templates/utility/multishell.cmd → src/modules/punk/mix/templates/layouts/project/src/scriptapps/wrappers/sample_punk-multishell.cmd
Unescape View File

10
src/modules/punk/mix/templates/utility/shellbat.txt → src/modules/punk/mix/templates/layouts/project/src/scriptapps/wrappers/sample_punk-shellbat.bat
Unescape View File

@ -26,6 +26,7 @@
#<tcl-payload>
#<tcl-payload/>
# --- --- --- --- --- --- --- --- --- --- --- --- ---
# 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"
#<shell-payload-pre-tcl>
#</shell-payload-pre-tcl>
#-- sh/bash launches Tcl here instead of shebang line at top
#-- sh/bash launches Tcl here instead of shebang line at top
#<shell-launch-tcl>
#-- use exec to use exitcode (if any) directly from the tcl script
exec /usr/bin/env tclsh "$0" "$@"
#</shell-launch-tcl>
#-- alternative - if sh/bash script required to run after the tcl call.
#/usr/bin/env tclsh "$0" "$@"
#tcl_exitcode=$?
#echo "tcl_exitcode: ${tcl_exitcode}"
#<shell-payload-post-tcl>
#</shell-payload-post-tcl>
#-- override exitcode example
#exit 66

270
src/modules/punk/mix/templates/utility/scriptappwrappers/punk-multishell.cmd
Unescape View File

@ -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"
# -- --- --- --- --- --- --- --- --- --- --- ---
#<tcl-payload>
#</tcl-payload>
# -- --- --- --- --- --- --- --- --- --- --- ---
# -- 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"
#<shell-payload-pre-tcl>
#</shell-payload-pre-tcl>
# -- --- --- --- --- --- --- ---
#<shell-launch-tcl>
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
#</shell-launch-tcl>
# -- --- --- --- --- --- --- ---
#<shell-payload-post-tcl>
#</shell-payload-post-tcl>
#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
# -- --- --- ---
#<powershell-payload-pre-tcl>
#</powershell-payload-pre-tcl>
# -- --- --- --- --- --- --- ---
#<powershell-launch-tcl>
tclsh $scriptname $args
#</powershell-launch-tcl>
# -- --- --- --- --- --- --- ---
#<powershell-payload-post-tcl>
#</powershell-payload-post-tcl>
# 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
# <ctrl-z>

# </ctrl-z>
# -- unreachable by tcl directly if ctrl-z character is in the <ctrl-z> 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)
#>

112
src/modules/punk/mix/templates/utility/scriptappwrappers/punk-shellbat.bat
Unescape View File

@ -0,0 +1,112 @@
: "[proc : args {}]" ;# *tcl shellbat - call with sh,bash,tclsh on any platform, or with cmd on windows.
: <<'HIDE_FROM_BASH_AND_SH'
: ;# leading colon hides from .bat, trailing slash hides next line from tcl \
@call tclsh "%~dp0%~n0.bat" %*
: ;#\
@set taskexitcode=%errorlevel% & goto :exit
# -*- tcl -*-
# #################################################################################################
# This is a tcl shellbat file
# It is tuned to run when called as a batch file, a tcl script, an sh script or a bash script,
# so the specific layout and characters used are quite sensitive to change.
# It can be called on unix or windows platforms with or without the interpreter being specified on the commandline.
# e.g ./filename.sh.bat in sh or bash or powershell
# e.g filename.sh or filename.sh.bat at windows command prompt
# e.g tclsh filename.sh.bat | sh filename.sh.bat | bash filename.sh.bat
# In all cases an arbitrary number of arguments are accepted
# To avoid the initial commandline on stdout when calling as a batch file on windows, use:
# cmd /Q /c filename.sh.bat
# (because we cannot use @if to silence it, as this isn't understood by tcl,sh or bash)
# #################################################################################################
#fconfigure stdout -translation crlf
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl Payload
#puts "script : [info script]"
#puts "argcount : $::argc"
#puts "argvalues: $::argv"
#<tcl-payload>
#<tcl-payload/>
# --- --- --- --- --- --- --- --- --- --- --- --- ---
# only exit if needed. see exitcode notes at bottom of file and exit there for consistency across invocation methods
# --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl Payload
#--
#-- bash/sh code follows.
#-- protect from tcl using line continuation char on the previous comment for each line, like so: \
printf "etc"
#-- or alternatively place sh/bash script within the false==false block
#-- whilst being careful to balance braces {}
#-- For more complex needs you should call out to external scripts
#--
#-- END marker for hide_from_bash_and_sh\
HIDE_FROM_BASH_AND_SH
#---------------------------------------------------------
#-- This if statement hides(mostly) a sh/bash code block from Tcl
if false==false # else {
then
:
#---------------------------------------------------------
#-- leave as is if all that's required is launching the Tcl payload"
#--
#-- Note that sh/bash script isn't called when running a .bat from cmd.exe on windows by default
#-- adjust line 4: @call tclsh ... to something like @call sh ... @call bash .. or @call env sh ... etc as appropriate
#-- if sh/bash scripting needs to run on windows too.
#--
#printf "start of bash or sh code"
#<shell-payload-pre-tcl>
#</shell-payload-pre-tcl>
#-- sh/bash launches Tcl here instead of shebang line at top
#<shell-launch-tcl>
#-- use exec to use exitcode (if any) directly from the tcl script
exec /usr/bin/env tclsh "$0" "$@"
#</shell-launch-tcl>
#-- alternative - if sh/bash script required to run after the tcl call.
#/usr/bin/env tclsh "$0" "$@"
#tcl_exitcode=$?
#echo "tcl_exitcode: ${tcl_exitcode}"
#<shell-payload-post-tcl>
#</shell-payload-post-tcl>
#-- override exitcode example
#exit 66
#printf "No need for trailing slashes for sh/bash code here\n"
#---------------------------------------------------------
fi
# closing brace for Tcl }
#---------------------------------------------------------
#-- tcl and shell script now both active
#-- comment for line sample 1 with trailing continuation slash \
#printf "tcl-invisible sh/bash line sample 1 \n"
#-- comment for line sample 2 with trailing continuation slash \
#printf "tcl-invisible sh/bash line sample 2 \n"
#-- Consistent exitcode from sh,bash,tclsh or cmd
#-- Call exit in tcl (or sh/bash) code only if explicitly required, otherwise leave this commented out.
#-- (script might be more widely useable without explicit exit. e.g in tcl: set ::argc 1; set ::argv "val"; source filename.sh.bat )
#-- exit line unprotected by trailing slash will work for tcl and/or sh/bash
#exit 0
#exit 42
#-- make sure sh/bash/tcl all skip over .bat style exit \
: <<'shell_end'
#-- .bat exit with exitcode from tcl process \
:exit
: ;# \
@exit /B %taskexitcode%
# .bat has exited \
shell_end

559
src/modules/punk/timeinterval-999999.0a1.0.tm
Unescape View File

@ -0,0 +1,559 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2023
#
# @@ Meta Begin
# Application punk::timeinterval 999999.0a1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
##e.g package require frobz
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# shamelessly grabbed from:
#https://wiki.tcl-lang.org/page/Measuring+time+intervals+%28between+two+timestamps%29+with+months+etc
#
namespace eval punk::timeinterval {
proc clock_scan_interval { seconds delta units } {
# clock_scan_interval formats $seconds to a string for processing by clock scan
# then returns new timestamp in seconds
set stamp [clock format $seconds -format "%Y%m%dT%H%M%S"]
if { $delta < 0 } {
append stamp " - " [expr { abs( $delta ) } ] " " $units
} else {
append stamp " + " $delta " " $units
}
return [clock scan $stamp]
}
namespace export difference
#wrap in dict
proc difference {s1 s2} {
lassign [interval_ymdhs $s1 $s2] Y M D h m s
return [dict create years $Y months $M days $D hours $h minutes $m seconds $s]
}
proc interval_ymdhs { s1 s2 } {
# interval_ymdhs calculates the interval of time between
# the earliest date and the last date
# by starting to count at the earliest date.
# This proc has audit features. It will automatically
# attempt to correct and report any discrepancies it finds.
# if s1 and s2 aren't in seconds, convert to seconds.
if { ![string is integer -strict $s1] } {
set s1 [clock scan $s1]
}
if { ![string is integer -strict $s2] } {
set s2 [clock scan $s2]
}
# postgreSQL intervals determine month length based on earliest date in interval calculations.
# set s1 to s2 in chronological sequence
set sn_list [lsort -integer [list $s1 $s2]]
set s1 [lindex $sn_list 0]
set s2 [lindex $sn_list 1]
# Arithmetic is done from most significant to least significant
# The interval is spanned in largest units first.
# A new position s1_pN is calculated for the Nth move along the interval.
# s1 is s1_p0
# Calculate years from s1_p0 to s2
set y_count 0
set s1_p0 $s1
set s2_y_check $s1_p0
while { $s2_y_check <= $s2 } {
set s1_p1 $s2_y_check
set y $y_count
incr y_count
set s2_y_check [clock_scan_interval $s1_p0 $y_count years]
}
# interval s1_p0 to s1_p1 counted in y years
# is the base offset incremented one too much?
set s2_y_check [clock_scan_interval $s1 $y years]
if { $s2_y_check > $s2 } {
set y [expr { $y - 1 } ]
set s2_y_check [clock_scan_interval $s1 $y years]
}
# increment s1 (s1_p0) forward y years to s1_p1
if { $y == 0 } {
set s1_p1 $s1
} else {
set s1_p1 [clock_scan_interval $s1 $y years]
}
# interval s1 to s1_p1 counted in y years
# Calculate months from s1_p1 to s2
set m_count 0
set s2_m_check $s1_p1
while { $s2_m_check <= $s2 } {
set s1_p2 $s2_m_check
set m $m_count
incr m_count
set s2_m_check [clock_scan_interval $s1_p1 $m_count months]
}
# interval s1_p1 to s1_p2 counted in m months
# Calculate interval s1_p2 to s2 in days
# day_in_sec [expr { 60 * 60 * 24 } ]
# 86400
# Since length of month is not relative, use math.
# Clip any fractional part.
set d [expr { int( ( $s2 - $s1_p2 ) / 86400. ) } ]
# Ideally, this should always be true, but daylight savings..
# so, go backward one day and make hourly steps for last day.
if { $d > 0 } {
incr d -1
}
# Move interval from s1_p2 to s1_p3
set s1_p3 [clock_scan_interval $s1_p2 $d days]
# s1_p3 is less than a day from s2
# Calculate interval s1_p3 to s2 in hours
# hour_in_sec [expr { 60 * 60 } ]
# 3600
set h [expr { int( ( $s2 - $s1_p3 ) / 3600. ) } ]
# Move interval from s1_p3 to s1_p4
set s1_p4 [clock_scan_interval $s1_p3 $h hours]
# s1_p4 is less than an hour from s2
# Sometimes h = 24, yet is already included as a day!
# For example, this case:
# interval_ymdhs 20010410T000000 19570613T000000
# from Age() example in PostgreSQL documentation:
# http://www.postgresql.org/docs/9.1/static/functions-datetime.html
# psql test=# select age(timestamp '2001-04-10', timestamp '1957-06-13');
# age
# -------------------------
# 43 years 9 mons 27 days
# (1 row)
# According to LibreCalc, the difference is 16007 days
#puts "s2=s1+16007days? [clock format [clock_scan_interval $s1 16007 days] -format %Y%m%dT%H%M%S]"
# ^ this calc is consistent with 16007 days
# So, let's ignore the Postgresql irregularity for now.
# Here's more background:
# http://www.postgresql.org/message-id/5A86CA18-593F-4517-BB83-995115A6A402@morth.org
# http://www.postgresql.org/message-id/200707060844.l668i89w097496@wwwmaster.postgresql.org
# So, Postgres had a bug..
# Sanity check: if over 24 or 48 hours, push it up to a day unit
set h_in_days [expr { int( $h / 24. ) } ]
if { $h >= 1 } {
# adjust hours to less than a day
set h [expr { $h - ( 24 * $h_in_days ) } ]
incr d $h_in_days
set h_correction_p 1
} else {
set h_correction_p 0
}
# Calculate interval s1_p4 to s2 in minutes
# minute_in_sec [expr { 60 } ]
# 60
set mm [expr { int( ( $s2 - $s1_p4 ) / 60. ) } ]
# Move interval from s1_p4 to s1_p5
set s1_p5 [clock_scan_interval $s1_p4 $mm minutes]
# Sanity check: if 60 minutes, push it up to an hour unit
if { $mm >= 60 } {
# adjust 60 minutes to 1 hour
# puts "interval_ymdhs: debug info mm - 60, h + 1"
set mm [expr { $mm - 60 } ]
incr h
set mm_correction_p 1
} else {
set mm_correction_p 0
}
# Calculate interval s1_p5 to s2 in seconds
set s [expr { int( $s2 - $s1_p5 ) } ]
# Sanity check: if 60 seconds, push it up to one minute unit
if { $s >= 60 } {
# adjust 60 minutes to 1 hour
set s [expr { $s - 60 } ]
incr mm
set s_correction_p 1
} else {
set s_correction_p 0
}
set return_list [list $y $m $d $h $mm $s]
# test results by adding difference to s1 to get s2:
set i 0
set s1_test [clock format $s1 -format "%Y%m%dT%H%M%S"]
set signs_inconsistent_p 0
foreach unit {years months days hours minutes seconds} {
set t_term [lindex $return_list $i]
if { $t_term != 0 } {
if { $t_term > 0 } {
append s1_test " + $t_term $unit"
} else {
append s1_test " - [expr { abs( $t_term ) } ] $unit"
set signs_inconsistent_p 1
}
}
incr i
}
set s2_test [clock scan $s1_test]
# puts "test s2 '$s2_test' from: '$s1_test'"
set counter 0
while { $s2 ne $s2_test && $counter < 30 } {
set s2_diff [expr { $s2_test - $s2 } ]
puts "\ninterval_ymdhs: debug s1 $s1 s2 $s2 y $y m $m d $d h $h s $s s2_diff $s2_diff"
if { [expr { abs($s2_diff) } ] > 86399 } {
if { $s2_diff > 0 } {
incr d -1
puts "interval_ymdhs: debug, audit adjustment. decreasing 1 day to $d"
} else {
incr d
puts "interval_ymdhs: debug, audit adjustment. increasing 1 day to $d"
}
} elseif { [expr { abs($s2_diff) } ] > 3599 } {
if { $s2_diff > 0 } {
incr h -1
puts "interval_ymdhs: debug, audit adjustment. decreasing 1 hour to $h"
} else {
incr h
puts "interval_ymdhs: debug, audit adjustment. increasing 1 hour to $h"
}
} elseif { [expr { abs($s2_diff) } ] > 59 } {
if { $s2_diff > 0 } {
incr mm -1
puts "interval_ymdhs: debug, audit adjustment. decreasing 1 minute to $mm"
} else {
incr mm
puts "interval_ymdhs: debug, audit adjustment. increasing 1 minute to $mm"
}
} elseif { [expr { abs($s2_diff) } ] > 0 } {
if { $s2_diff > 0 } {
incr s -1
puts "interval_ymdhs: debug, audit adjustment. decreasing 1 second to $s"
} else {
incr s
puts "interval_ymdhs: debug, audit adjustment. increasing 1 second to $s"
}
}
set return_list [list $y $m $d $h $mm $s]
# set return_list [list [expr { abs($y) } ] [expr { abs($m) } ] [expr { abs($d) } ] [expr { abs($h) } ] [expr { abs($mm) } ] [expr { abs($s) } ]]
# test results by adding difference to s1 to get s2:
set i 0
set s1_test [clock format $s1 -format "%Y%m%dT%H%M%S"]
foreach unit {years months days hours minutes seconds} {
set t_term [lindex $return_list $i]
if { $t_term != 0 } {
if { $t_term > 0 } {
append s1_test " + $t_term $unit"
} else {
append s1_test " - [expr { abs( $t_term ) } ] $unit"
}
}
incr i
}
set s2_test [clock scan $s1_test]
incr counter
}
if { ( $counter > 0 || $signs_inconsistent_p ) && ( $h_correction_p || $mm_correction_p || $s_correction_p ) } {
# puts "interval_ymdhs: Corrections in the main calculation were applied: h ${h_correction_p}, mm ${mm_correction_p}, s ${s_correction_p}"
}
if { $signs_inconsistent_p } {
puts "\ninterval_ymdhs: signs inconsistent y $y m $m d $d h $h mm $mm s $s"
}
if { $s2 eq $s2_test } {
return $return_list
} else {
set s2_diff [expr { $s2_test - $s2 } ]
puts "debug s1 $s1 s1_p1 $s1_p1 s1_p2 $s1_p2 s1_p3 $s1_p3 s1_p4 $s1_p4"
puts "debug y $y m $m d $d h $h mm $mm s $s"
puts "interval_ymdhs error: s2 is '$s2' but s2_test is '$s2_test' a difference of ${s2_diff} from s1 '$s1_test'."
# error "result audit fails" "error: s2 is $s2 but s2_test is '$s2_test' a difference of ${s2_diff} from: '$s1_test'."
}
}
proc interval_ymdhs_w_units { t1 t2 } {
# interval_ymdhs_w_units
# returns interval_ymdhs values with units
set v_list [interval_ymdhs $t2 $t1]
set i 0
set a ""
foreach f {years months days hours minutes seconds} {
append a "[lindex $v_list $i] $f \n"
incr i
}
return $a
}
proc interval_remains_ymdhs { s1 s2 } {
# interval_remains_ymdhs calculates the interval of time between
# the earliest date and the last date
# by starting to count at the last date and work backwards in time.
# This proc has audit features. It will automatically
# attempt to correct and report any discrepancies it finds.
# if s1 and s2 aren't in seconds, convert to seconds.
if { ![string is integer -strict $s1] } {
set s1 [clock scan $s1]
}
if { ![string is integer -strict $s2] } {
set s2 [clock scan $s2]
}
# set s1 to s2 in reverse chronological sequence
set sn_list [lsort -decreasing -integer [list $s1 $s2]]
set s1 [lindex $sn_list 0]
set s2 [lindex $sn_list 1]
# Arithmetic is done from most significant to least significant
# The interval is spanned in largest units first.
# A new position s1_pN is calculated for the Nth move along the interval.
# s1 is s1_p0
# Calculate years from s1_p0 to s2
set y_count 0
set s1_p0 $s1
set s2_y_check $s1_p0
while { $s2_y_check > $s2 } {
set s1_p1 $s2_y_check
set y $y_count
incr y_count -1
set s2_y_check [clock_scan_interval $s1_p0 $y_count years]
}
# interval s1_p0 to s1_p1 counted in y years
# Calculate months from s1_p1 to s2
set m_count 0
set s2_m_check $s1_p1
while { $s2_m_check > $s2 } {
set s1_p2 $s2_m_check
set m $m_count
incr m_count -1
set s2_m_check [clock_scan_interval $s1_p1 $m_count months]
}
# interval s1_p1 to s1_p2 counted in m months
# Calculate interval s1_p2 to s2 in days
# day_in_sec [expr { 60 * 60 * 24 } ]
# 86400
# Since length of month is not relative, use math.
# Clip any fractional part.
set d [expr { int( ceil( ( $s2 - $s1_p2 ) / 86400. ) ) } ]
# Ideally, this should always be true, but daylight savings..
# so, go backward one day and make hourly steps for last day.
if { $d < 0 } {
incr d
}
# Move interval from s1_p2 to s1_p3
set s1_p3 [clock_scan_interval $s1_p2 $d days]
# s1_p3 is less than a day from s2
# Calculate interval s1_p3 to s2 in hours
# hour_in_sec [expr { 60 * 60 } ]
# 3600
set h [expr { int( ceil( ( $s2 - $s1_p3 ) / 3600. ) ) } ]
# Move interval from s1_p3 to s1_p4
set s1_p4 [clock_scan_interval $s1_p3 $h hours]
# s1_p4 is less than an hour from s2
# Sanity check: if over 24 or 48 hours, push it up to a day unit
set h_in_days [expr { int( ceil( $h / 24. ) ) } ]
if { $h_in_days <= -1 } {
# adjust hours to less than a day
set h [expr { $h - ( 24 * $h_in_days ) } ]
incr d $h_in_days
set h_correction_p 1
} else {
set h_correction_p 0
}
# Calculate interval s1_p4 to s2 in minutes
# minute_in_sec [expr { 60 } ]
# 60
set mm [expr { int( ceil( ( $s2 - $s1_p4 ) / 60. ) ) } ]
# Move interval from s1_p4 to s1_p5
set s1_p5 [clock_scan_interval $s1_p4 $mm minutes]
# Sanity check: if 60 minutes, push it up to an hour unit
if { $mm <= -60 } {
# adjust 60 minutes to 1 hour
# puts "interval_remains_ymdhs: debug info mm + 60, h - 1"
set mm [expr { $mm + 60 } ]
incr h -1
set mm_correction_p 1
} else {
set mm_correction_p 0
}
# Calculate interval s1_p5 to s2 in seconds
set s [expr { $s2 - $s1_p5 } ]
# Sanity check: if 60 seconds, push it up to one minute unit
if { $s <= -60 } {
# adjust 60 minutes to 1 hour
set s [expr { $s + 60 } ]
incr mm -1
set s_correction_p 1
} else {
set s_correction_p 0
}
set return_list [list $y $m $d $h $mm $s]
# set return_list [list [expr { abs($y) } ] [expr { abs($m) } ] [expr { abs($d) } ] [expr { abs($h) } ] [expr { abs($mm) } ] [expr { abs($s) } ]]
# test results by adding difference to s1 to get s2:
set i 0
set s1_test [clock format $s1 -format "%Y%m%dT%H%M%S"]
set signs_inconsistent_p 0
foreach unit {years months days hours minutes seconds} {
set t_term [lindex $return_list $i]
if { $t_term != 0 } {
if { $t_term > 0 } {
append s1_test " + $t_term $unit"
set signs_inconsistent_p 1
} else {
append s1_test " - [expr { abs( $t_term ) } ] $unit"
}
}
incr i
}
set s2_test [clock scan $s1_test]
set counter 0
while { $s2 ne $s2_test && $counter < 3 } {
set s2_diff [expr { $s2_test - $s2 } ]
puts "\ninterval_remains_ymdhs: debug s1 $s1 s2 $s2 y $y m $m d $d h $h s $s s2_diff $s2_diff"
if { [expr { abs($s2_diff) } ] >= 86399 } {
if { $s2_diff > 0 } {
incr d -1
puts "interval_remains_ymdhs: debug, audit adjustment. decreasing 1 day to $d"
} else {
incr d
puts "interval_remains_ymdhs: debug, audit adjustment. increasing 1 day to $d"
}
} elseif { [expr { abs($s2_diff) } ] > 3599 } {
if { $s2_diff > 0 } {
incr h -1
puts "interval_remains_ymdhs: debug, audit adjustment. decreasing 1 hour to $h"
} else {
incr h
puts "interval_remains_ymdhs: debug, audit adjustment. increasing 1 hour to $h"
}
} elseif { [expr { abs($s2_diff) } ] > 59 } {
if { $s2_diff > 0 } {
incr mm -1
puts "interval_remains_ymdhs: debug, audit adjustment. decreasing 1 minute to $mm"
} else {
incr mm
puts "interval_remains_ymdhs: debug, audit adjustment. increasing 1 minute to $mm"
}
} elseif { [expr { abs($s2_diff) } ] > 0 } {
if { $s2_diff > 0 } {
incr s -1
puts "interval_remains_ymdhs: debug, audit adjustment. decreasing 1 second to $s"
} else {
incr s
puts "interval_remains_ymdhs: debug, audit adjustment. increasing 1 second to $s"
}
}
set return_list [list $y $m $d $h $mm $s]
# set return_list [list [expr { abs($y) } ] [expr { abs($m) } ] [expr { abs($d) } ] [expr { abs($h) } ] [expr { abs($mm) } ] [expr { abs($s) } ]]
# test results by adding difference to s1 to get s2:
set i 0
set s1_test [clock format $s1 -format "%Y%m%dT%H%M%S"]
foreach unit {years months days hours minutes seconds} {
set t_term [lindex $return_list $i]
if { $t_term != 0 } {
if { $t_term > 0 } {
append s1_test " + $t_term $unit"
} else {
append s1_test " - [expr { abs( $t_term ) } ] $unit"
}
}
incr i
}
set s2_test [clock scan $s1_test]
incr counter
}
if { ( $counter > 0 || $signs_inconsistent_p ) && ( $h_correction_p || $mm_correction_p || $s_correction_p ) } {
# puts "interval_remains_ymdhs: Corrections in the main calculation were applied: h ${h_correction_p}, mm ${mm_correction_p}, s ${s_correction_p}"
}
if { $signs_inconsistent_p } {
puts "\ninterval_remains_ymdhs: signs inconsistent y $y m $m d $d h $h mm $mm s $s"
}
if { $s2 eq $s2_test } {
return $return_list
} else {
set s2_diff [expr { $s2_test - $s2 } ]
puts "debug s1 $s1 s1_p1 $s1_p1 s1_p2 $s1_p2 s1_p3 $s1_p3 s1_p4 $s1_p4"
puts "debug y $y m $m d $d h $h mm $mm s $s"
puts "interval_remains_ymdhs error: s2 is '$s2' but s2_test is '$s2_test' a difference of ${s2_diff} from s1 '$s1_test'."
# error "result audit fails" "error: s2 is $s2 but s2_test is '$s2_test' a difference of ${s2_diff} from: '$s1_test'."
}
}
proc interval_remains_ymdhs_w_units { t1 t2 } {
# interval_remains_ymdhs_w_units
# returns interval_remains_ymdhs values with units
set v_list [interval_ymdhs $t2 $t1]
set i 0
set a ""
foreach f {years months days hours minutes seconds} {
append a "[lindex $v_list $i] $f \n"
incr i
}
return $a
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::timeinterval [namespace eval punk::timeinterval {
variable version
set version 999999.0a1.0
}]
return

3
src/modules/punk/timeinterval-buildversion.txt
Unescape View File

@ -0,0 +1,3 @@
0.1.0
#First line must be a semantic version number
#all other lines are ignored.

16
src/modules/punk/winpath-999999.0a1.0.tm
Unescape View File

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

28
src/modules/punkapp-0.1.tm
Unescape View File

@ -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
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]} {
#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.

10
src/modules/shellfilter-0.1.8.tm
Unescape View File

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

119
src/modules/shellthread-1.6.tm
Unescape View File

@ -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 <tidworker> list_client_tids <clients>] ts_start <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"

72
src/modules/tcl9test-999999.0a1.0.tm
Unescape View File

@ -0,0 +1,72 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2023
#
# @@ Meta Begin
# Application tcl9test 999999.0a1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
##e.g package require frobz
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
foreach base [tcl::tm::list] {
if {[string match -nocase "${base}*" [info script]]} {
set nsprefix [join [lrange [file split [string trimleft [string range [info script] [string length $base] end] /]] 0 end-1] ::]
if {[string length $nsprefix]} {set nsprefix ${nsprefix}::}
break
}
}
namespace eval [lassign [split [file rootname [file tail [info script] ]] -] pkgtail verparts]$nsprefix$pkgtail[unset pkgtail] {
#--------------------------------------
#unset ::nsparts; unset ::base
variable pkg [namespace current]
variable pkgtail [namespace tail [namespace current]]
variable version [join $::verparts -][unset ::verparts]
#--------------------------------------
puts stdout "-->[info script]"
puts stdout "-->[namespace current]"
uplevel #0 [list package provide $pkgtail $version]
#package provide [lassign {tcl9test 999999.0a1.0} pkg ver]$pkg [namespace eval $pkg[set pkg {}] {list [variable version $::ver[set ::ver {}]]$version}]
}
#package provide [lassign {tcl9test 999999.0a1.0} pkg ver]$pkg [namespace eval $pkg[set pkg {}] {list [variable version $::ver[set ::ver {}]]$version}]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
#package provide tcl9test [namespace eval tcl9test {
# variable version
# set version 999999.0a1.0
#}]
#return

3
src/modules/tcl9test-buildversion.txt
Unescape View File

@ -0,0 +1,3 @@
0.1.0
#First line must be a semantic version number
#all other lines are ignored.

246
src/modules/winlibreoffice-999999.0a1.0.tm
Unescape View File

@ -0,0 +1,246 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2023
#
# @@ Meta Begin
# Application winlibreoffice 999999.0a1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
##e.g package require frobz
package require uri ;#tcllib
#windows? REVIEW - can we provide a common api for other platforms with only script? tcluno instead?
if {"windows" eq $::tcl_platform(platform)} {
if {[catch {package require twapi}]} {
puts stderr "Twapi package required for winlibreoffice to function"
puts stderr "Minimal functionality - only some utils may work"
}
} else {
puts stderr "Package requires twapi. No current equivalent on non-windows platform. Try tcluno http://sf.net/projets/tcluno "
puts stderr "Minimal functionality - only some utils may work"
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval winlibreoffice {
#---
#todo: investigate tcluno package http://sf.net/projects/tcluno
#CPlusPlus - platforms?
#---
#
#enable 1
variable datebase "1899-12-30" ;#libreoffice default in options->LibreOfifce Calc->Calculate
#variable datebase "1900-01-01" ;#StarCalc 1.0
#variable datebase "1904-01-01" ;# ???
#sometimes a com object may support $obj -print
#see also
# $obj -destroy
# $obj Quit
# $collection -iterate ?options? varname script
variable uno "" ;# service manager object
variable psm "" ;# process service manager
# -- --- --- ---
# libreoffice functions
proc getServiceManager {} {
variable uno
if {$uno eq ""} {
set uno [twapi::comobj com.sun.star.ServiceManager]
}
return $uno
}
#uno getAvailableServiceNames
#e.g com.sun.star.beans.Introspection
# com.sun.star.ucb.SimpleFileAccess
proc createUnoService {objname} {
[getProcessServiceManager] createInstance $objname
}
proc getProcessServiceManager {} {
variable psm
if {$psm eq ""} {
set svcmgr [getServiceManager]
#set psm [$svcmgr getProcessServiceManager]
#seems to be same object? - it has createInstance anyway REVIEW
set psm $svcmgr
}
return $psm
}
#what does libreoffice accept for this fun.. local file paths only?
proc convertToUrl {fpath} {
if {![string match "file:/*" $fpath]} {
# this turns //server/blah to file:////server/blah - which is probably nonsense
set fpath [uri::join scheme file path $fpath]
}
return $fpath
}
#this
proc convertFromUrl {fileuri} {
if {[string match "file:/*" $fileuri]} {
set finfo [uri::split $fileuri]
if {"windows" eq $::tcl_platform(platform)} {
if {[dict exists $finfo host]} {
return "//${host}${path}"
} else {
#the leading slash in path indicates a local path and we strip on windows
set p [dict get $finfo path]
if {[string index $p 0] eq "/"} {
set p [string range $p 1 end]
}
return $p
}
} else {
if {[dict exists $finfo host]} {
#?? review - how are file uris to other hosts handled?
error "convertFromUrl doesn't handle non-local file uris on this platform"
} else {
return [dict get $finfo path]
}
}
}
}
# -- --- --- ---
# custom functions
proc get_desktop {} {
set uno [getServiceManager]
set ctx [$uno getPropertyValue "DefaultContext"]
set dt [$ctx getByName /singletons/com.sun.star.frame.theDesktop]
#$dt setName odk_officedev_desk
#$dt getName
return $dt
}
proc blankdoc {{type scalc}} {
set known_types [list scalc swriter simpress sdraw smath]
if {$type ni $known_types} {
puts stderr "Warning: unknown type $type. (known types: $known_types) will try anyway - private:factory/$type"
}
set dt [get_desktop]
set doc [$dt loadComponentFromUrl "private:factory/$type" "_blank" 0 ""] ;#doesn't work without final param - empty string seems to work
puts "doc title: [$doc Title]"
return $doc
}
proc file_open_dialog {{title "pick a libreoffice file"}} {
set filepicker [createUnoService "com.sun.star.ui.dialogs.FilePicker"]
$filepicker Title $title
set result [$filepicker Execute]
if {$result} {
#set files [$filepicker getSelectedFiles]
# -iterate ?
# return files(0) ?
#e.g file:///C:/Users/sleek/test.txt
return [$filepicker getFiles]
} else {
return ""
}
}
#todo oo interface?
proc calcdoc_sheets_by_index {doc idx} {
set sheets [$doc getSheets]
set s [$sheets getByIndex $idx]
puts stdout "Sheet: [$s getName]"
return $s
}
proc calcsheet_cell_range_by_name {sheet rangename} {
return [$sheet getCellRangeByName $rangename] ;#e.g A1
}
proc calccell_setString {cell str} {
$cell setString $str
}
proc calccell_setValue {cell value} {
$cell setValue $value
}
proc calccell_setPropertyValue {cell propset} {
$cell setPropertyValue {*}$propset
#e.g "NumberFormat" 49
# YYYY-MM-DD
}
#a hack
#return libreoffice date in days since 1899..
proc date_from_clockseconds_approx {cs} {
variable datebase
set tbase [clock scan $datebase]
package require punk::timeinterval
set diff [punk::timeinterval::difference $tbase $cs]
set Y [dict get $diff years]
set M [dict get $diff months]
set D [dict get $diff days]
set yeardays [expr 365.25 * $Y]
set monthdays [expr 30.437 * $M]
#yes.. this is horrible.. just a test really - but gets in the ballpark.
return [expr int($yeardays + $monthdays + $D)]
}
#time is represented on a scale of 0 to 1 6:00am = 0.25 (24/4)
proc date_from_clockseconds {cs} {
puts stderr "unimplemented"
}
#see also: https://wiki.tcl-lang.org/page/Tcom+examples+for+Microsoft+Outlook
# this also uses days since 1899 (but 31 dec?) and uses a fixed base_offset of 36526 (for 2000-01-01) - this might be a better approach than using punk::timeinterval anyway
# it seems to match libreoffice very closely (if not exact?) REVIEW
# wher val is days since 1899
proc msdate_to_iso {val} {
set base_ticks [clock scan 20000101]
set base_offset 36526;# days since 31. Dec 1899, ARRRGGHHHHH
set offset [expr {int($val)-$base_offset}]
set clkdate [clock scan "$offset days" -base $base_ticks]
set isodate [clock format $clkdate -format %Y%m%d]
set fhours [expr {24.0*($val-int($val))}]
set hours [expr {int($fhours)}]
set mins [expr {int(($fhours-$hours)*60)}]
#date<sp>H:m is valid iso but not if space replaced with T - then would need seconds too
return "${isodate} $hours:$mins"
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide winlibreoffice [namespace eval winlibreoffice {
variable version
set version 999999.0a1.0
}]
return

3
src/modules/winlibreoffice-buildversion.txt
Unescape View File

@ -0,0 +1,3 @@
0.1.0
#First line must be a semantic version number
#all other lines are ignored.

49
src/punk86.vfs/lib/app-punk/repl.tcl
Unescape View File

@ -9,30 +9,13 @@ 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
# - 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
}
}

8
src/punk86.vfs/main.tcl
Unescape View File

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

902
src/scriptapps/tcltm
Unescape View File

@ -0,0 +1,902 @@
#!/bin/sh
# the next line restarts using tclsh \
exec tclsh "$0" ${1+"$@"}
if { ![package vsatisfies [package provide Tcl] 8.5] } {puts stdout "Tcl: >= 8.5 is required"; return}
if { ![package vsatisfies [package require sha1] 2.0.3] } {puts stdout "sha1: >= 2.0.3 is required"; return}
if { ![package vsatisfies [package require yaml] 0.3.6] } {puts stdout "yaml: >= 0.3.6 is required"; return}
namespace eval ::tcltm::binary {
proc readfile { dir file } {
set b [open [file normalize [filename $dir $file]]]
fconfigure $b -translation binary
fconfigure $b -encoding binary
set data [read $b]
close $b
return $data
}
proc filesize { dir file } {
return [string length [readfile $dir $file]]
}
proc filename { dir file } {
set f $file
if { [string match {*\**} $f] } {
set f [glob -directory $dir $f]
return $f
}
return [file normalize [file join $dir $file]]
}
proc hash { dir file } {
return [::sha1::sha1 -hex -file [filename $dir $file]]
}
proc encode { dir file } {
set info [dict create]
dict set info size [filesize $dir $file]
dict set info hash [hash $dir $file]
return $info
}
proc present { flist } {
return [expr {[llength [files $flist]] > 0 ? 1 : 0}]
}
proc files { flist } {
set filelist [list]
for {set fidx 0} {$fidx < [llength $flist]} {incr fidx} {
set fcfg [lindex $flist $fidx]
if { ![dict exists $fcfg type] } {
dict set fcfg type "script"
}
if { [string toupper [dict get $fcfg type]] eq "BINARY" } {
lappend filelist $fcfg
}
}
return $filelist
}
}
namespace eval ::tcltm::config {
proc exists { dir {cfg .tcltm} } {
set fname [file normalize [file join $dir $cfg]]
return [file exists $fname]
}
proc load { dir {cfg .tcltm} } {
set fname [file normalize [file join $dir $cfg]]
return [::yaml::yaml2dict -file $fname -m:true {1 {true on}} -m:false {0 {false off}}]
}
proc merge { cfg opts } {
dict set cfg options $opts
return $cfg
}
proc parse { cfg } {
set pkgs [list]
foreach p [dict get $cfg package] {
if { [dict exists $p filter] } {
set filter [list]
foreach {k v} [dict get $p filter] {
lappend filter "$k [::tcltm::env::resolve $v]"
}
dict set p filter $filter
}
set files [list]
foreach f [dict get $p files] {
if { [dict exists $f filter] } {
set filter [list]
foreach {k v} [dict get $f filter] {
lappend filter "$k [::tcltm::env::resolve $v]"
}
dict set f filter $filter
}
lappend files $f
}
dict set p files $files
if { [dict exists $p version] } {
dict set p version [::tcltm::env::resolve [dict get $p version]]
}
if { [dict get $cfg options version-from-index] } {
set idx [file normalize [file join [dict get $cfg options in] pkgIndex.tcl]]
if { [file exists $idx] } {
set results [::tcltm::scan $idx]
foreach {f res} $results {
if { $f eq $idx } {
foreach pkg $res {
if { [dict get $p name] eq [dict get $pkg package] && [dict get $pkg type] eq "ifneeded" } {
dict set p version [dict get $pkg version]
}
}
}
}
}
}
lappend pkgs $p
}
dict set cfg package $pkgs
return $cfg
}
}
namespace eval ::tcltm::env {
proc resolve { val } {
set v {}
if { [string tolower [string range $val 0 3]] eq "env:" } {
set l [split $val ":"]
if { [info exists ::env([lindex $l 1])] } {
set v $::env([lindex $l 1])
} elseif { [llength $l] == 3 } {
set v [lindex $l 2]
} else {
error "environment variable '[lindex $l 1]' does not exists"
}
} else {
set v $val
}
return $v
}
}
namespace eval ::tcltm::filter {
proc line { str key value } {
regsub -all -- "@${key}@" $str $value str
return $str
}
proc lines { data key value } {
set lines [list]
foreach l [split $data "\n"] {
lappend lines [line $l $key $value]
}
return [join $lines "\n"]
}
proc multi { data args } {
set lines [list]
foreach l [split $data "\n"] {
set line $l
foreach {k v} $args {
set line [line $line $k $v]
}
lappend lines $line
}
return [join $lines "\n"]
}
proc lfile { pkg file } {
set filter [list]
if { [dict exists $pkg filter] } {
lappend filter [dict get $pkg filter]
}
foreach f [dict get $pkg files] {
if { [dict exists $f filter] && [dict get $f name] eq $file } {
lappend filter [dict get $f filter]
}
}
return $filter
}
}
namespace eval ::tcltm::license {
proc exists { dir {filename LICENSE} } {
set fname [file normalize [file join $dir $filename]]
return [file exists $fname]
}
proc load { dir {filename LICENSE} } {
set fname [file normalize [file join $dir $filename]]
set fh [open $fname RDONLY]
set data [read $fh]
close $fh
return $data
}
proc format { data } {
set license [list]
lappend license $::tcltm::markup::divider
foreach line [split $data "\n"] {
if { $line eq {} } {
lappend license "#"
} else {
lappend license [::tcltm::markup::comment $line]
}
}
lappend license $::tcltm::markup::divider
return $license
}
}
namespace eval ::tcltm::loader {
variable script {
namespace eval ::tcltm::binary {
variable path
variable resources
variable name
proc loader {} {
variable path
variable resources [list]
variable name
if { ![info exists path] || [string length $path] == 0 } {
set path [file normalize [file dirname [info script]]]
}
set bin [open [info script] {RDONLY BINARY}]
set header 0
while { [gets $bin line] >= 0 } {
if { [string match {*TCLTM*HEADER*BEGIN*} $line] } {
set header 1
continue
}
if { [string match {*TCLTM*HEADER*END*} $line] } {
break
}
if { [string match {*NAME*} $line] } {
regexp {^# ([[:alpha:]]+): ([[:alpha:]]+$)} $line -> - name
}
if { [string match {*RESOURCE*} $line] } {
set res {*}[string trimleft [lindex [split $line ":"] 1]]
dict lappend resources files [dict get $res NAME]
dict set resources [dict get $res NAME] $res
}
}
seek $bin 0
set bindata [read $bin]
close $bin
set bindex [string first \\u001A $bindata]
incr bindex
foreach f [dict get $resources files] {
set finfo [dict get $resources $f]
set tmp [file normalize [file join $path [dict get $finfo NAME]]]
if { ![file exists [file dirname $tmp]] } {
file mkdir [file dirname $tmp]
}
set fh [open $tmp w]
fconfigure $fh -translation binary
fconfigure $fh -encoding binary
puts -nonewline $fh [string range $bindata $bindex [incr bindex [dict get $finfo SIZE]]-1]
flush $fh
close $fh
if { [package vsatisfies [package require sha1] 2.0.3] } {
set hash [::sha1::sha1 -hex -file $tmp]
if { $hash ne [dict get $finfo HASH] } {
return -code error "[file tail [info script]]: Hash invalid for embedded binary [dict get $finfo NAME]"
}
}
if { [dict exists $finfo ACTION] } {
switch -exact -- [string toupper [dict get $finfo ACTION]] {
NONE {
}
RUN {
if { [catch {source $tmp} err] } {
return -code error "Failed to run embedded resource: $tmp"
}
}
LOAD {
if { [catch {load $tmp}] } {
if { [catch {load $tmp $name}] } {
return -code error "[file tail [info script]]: failed to load embedded binary [dict get $finfo NAME]"
}
}
}
EXTRACT {
}
default {
}
}
}
incr bindex
}
}
}
} ; # END Variable script
variable action {
::tcltm::binary::loader
};
variable interactive {
if { $tcl_interactive } {
::tcltm::binary::loader
}
}
} ; # END Namespace
namespace eval ::tcltm::markup {
variable divider [string repeat "#" 80]
proc comment { n args } {
set line {}
if { [llength $args] } {
set line [format {# %s %s} $n [join $args]]
} else {
set line [format {# %s} $n]
}
return $line
}
proc iscomment { line } {
if { [string index $line 0] eq "#" } {
return 1
}
return 0
}
proc nl {} {
return {}
}
proc meta { n args } {
if { [llength $args] } {
set line [format {# %s: %s} [string toupper $n] [join $args]]
} else {
set line [format {# %s} [string toupper $n]]
}
return $line
}
proc script { body args } {
regsub -all "\n$" $body {} body
return [string trimleft [format "[subst -nocommands -novariables $body]" {*}$args] "\n"]
}
}
namespace eval ::tcltm::module {
variable config [dict create]
variable content [list]
proc new { cfg pkg } {
variable config $cfg
variable content
set config $cfg
set content [list]
if { [dict exists [pkgcfg $pkg] interp] } {
lappend content "#!/usr/bin/env [dict get [pkgcfg $pkg] interp]"
lappend content [::tcltm::markup::comment "Windows Magic Header \\"]
lappend content "exec [dict get [pkgcfg $pkg] interp] \"\$0\" \"\$@\""
lappend content [::tcltm::markup::nl]
}
lappend content [::tcltm::markup::comment "Tcl Module Generated by tcltm; DO NOT EDIT"]
lappend content [::tcltm::markup::nl]
return -code ok
}
proc pkgcfg { pkg } {
variable config
foreach p [dict get $config package] {
if { [dict get $p name] eq $pkg } {
return $p
}
}
return -code ok
}
proc write { pkg } {
variable config
variable content
variable cfg [pkgcfg $pkg]
set ext .tm
if { [dict exists $cfg extension] } {
set ext [dict get $cfg extension]
}
if { [dict exists $cfg finalname] && [string length [dict get $cfg finalname]] > 0 } {
set filename [dict get $cfg finalname]
} else {
if { [dict exists $cfg fileversion] } {
set fileversion [::tcltm::env::resolve [dict get $cfg fileversion]]
set filename [format {%s-%s%s} [dict get $cfg name] $fileversion $ext]
} else {
set filename [format {%s-%s%s} [dict get $cfg name] [dict get $cfg version] $ext]
}
}
regsub -all -- {::} $filename {/} filename
set filepath [file normalize [file join [file normalize [dict get $config options out]] $filename]]
if { [dict get $config options repo] } {
set tcldir "tcl[lindex [split [dict get $cfg tcl] "."] 0]"
set outdir [file normalize [file join [dict get $config options out] $tcldir [dict get $cfg tcl]]]
if { [catch {file mkdir $outdir} err] } {
puts stdout "Failed to create output directory ${outdir}: $err"; flush stdout
exit 1
}
set filepath [file join $outdir $filename]
}
if { [catch {file mkdir [file dirname $filepath]} err] } {
puts stdout "Failed to create [file dirname $filepath]: $err"
exit 1
}
if { [::tcltm::binary::present [dict get $cfg files]] } {
lappend content [::tcltm::markup::nl]
lappend content [::tcltm::markup::comment "BINARY SECTION"]
}
set fh [open $filepath w]
fconfigure $fh -translation lf
set lines [join $content "\n"]
regsub -all -- {\n\n\n+} $lines "\n\n" lines
puts $fh $lines
if { [::tcltm::binary::present [dict get $cfg files]] } {
puts -nonewline $fh "\u001A"
fconfigure $fh -translation binary
set binfiles [::tcltm::binary::files [dict get $cfg files]]
foreach f $binfiles {
puts stdout "Encoding: [dict get $f name]"
puts $fh [::tcltm::binary::readfile [dict get $config options in] [dict get $f name]]
}
}
close $fh
puts stdout "Module: $filename \[$filepath\]"
return -code ok
}
proc license { pkg } {
variable config
variable content
variable cfg [pkgcfg $pkg]
if { ![dict exists $cfg license] || [string length [dict get $cfg license]] == 0 } {
if { [::tcltm::license::exists [dict get $config options in]] } {
dict set cfg license [::tcltm::license::load [dict get $config options in]]
}
}
if { [dict exists $cfg license] && [string length [dict get $cfg license]] > 0 } {
if { [llength [split [dict get $cfg license] "\n"]] == 1 } {
dict set cfg license [::tcltm::license::load [dict get $config options in] [dict get $cfg license]]
}
}
if { [dict exists $cfg license] && [string length [dict get $cfg license]] > 0 } {
lappend content {*}[::tcltm::license::format [dict get $cfg license]]
lappend content [::tcltm::markup::nl]
}
return -code ok
}
proc header { pkg } {
variable config
variable content
variable cfg [pkgcfg $pkg]
lappend content [::tcltm::markup::comment "TCLTM HEADER BEGIN"]
foreach key {name version summary description Tcl} {
if { [dict exists $cfg $key] && [string length [dict get $cfg $key]] > 0 } {
if { [string tolower $key] eq "description" } {
foreach line [split [dict get $cfg $key] "\n"] {
lappend content [::tcltm::markup::meta "DESCRIPTION" $line]
}
} else {
lappend content [::tcltm::markup::meta $key [dict get $cfg $key]]
}
}
}
if { [dict exists $cfg dependencies] && [string length [dict get $cfg dependencies]] > 0 } {
foreach r [dict get $cfg dependencies] {
lappend content [::tcltm::markup::meta "REQUIRE" $r]
}
}
set files [list]
set bidx 0
for {set fidx 0} {$fidx < [llength [dict get $cfg files]]} {incr fidx} {
set fcfg [lindex [dict get $cfg files] $fidx]
if { ![dict exists $fcfg type] } {
dict set fcfg type "script"
}
if { [string toupper [dict get $fcfg type]] eq "BINARY" } {
dict set fcfg id $bidx
incr bidx
if { [string match {*\**} [dict get $fcfg name]] } {
set f [glob -directory [dict get $config options in] [dict get $fcfg name]]
dict set fcfg name [file tail $f]
}
set enc [::tcltm::binary::encode [dict get $config options in] [dict get $fcfg name]]
set fcfg [list {*}$fcfg {*}$enc]
set name [dict get $fcfg name]
if { [dict get $config options strip-resource-dir] } {
set name [file tail $name]
}
set header [format {ID %s NAME %s SIZE %s HASH %s} \
[dict get $fcfg id] \
$name \
[dict get $fcfg size] \
[dict get $fcfg hash] \
]
if { [dict exists $fcfg action] } {
append header " ACTION [dict get $fcfg action]"
}
if { [dict exists $fcfg target] } {
append header " TARGET [dict get $fcfg target]"
}
lappend content [::tcltm::markup::meta "RESOURCE" [format "{%s}" $header]]
}
lappend files $fcfg
}
lappend content [::tcltm::markup::comment "TCLTM HEADER END"]
return -code ok
}
proc satisfy-tcl-version { pkg } {
variable config
variable content
variable cfg [pkgcfg $pkg]
if { ![dict get $config options exclude-satisfy-tcl] } {
lappend content [::tcltm::markup::nl]
lappend content [::tcltm::markup::script {
if { ![package vsatisfies [package provide Tcl] %s] } {
return -code error "Unable to load module '%s' Tcl: '%s' is required"
}
} [dict get $cfg tcl] [dict get $cfg name] [dict get $cfg tcl]]
}
return -code ok
}
proc deps { pkg } {
variable config
variable content
variable cfg [pkgcfg $pkg]
if { ![dict get $config options exclude-deps] } {
if { [dict exists $cfg dependencies] && [string length [dict get $cfg dependencies]] > 0 } {
lappend content [::tcltm::markup::nl]
foreach r [dict get $cfg dependencies] {
lappend content [::tcltm::markup::script {package require %s} $r]
}
}
}
return -code ok
}
proc script { pkg type } {
variable config
variable content
variable cfg [pkgcfg $pkg]
set filter [list]
lappend filter "PNAME [dict get $cfg name]"
if { [dict exists $cfg version] } {
lappend filter "PVERSION \"[dict get $cfg version]\""
}
if { [dict exists $pkg filter] } {
lappend filter [dict get $pkg filter]
}
if { [dict exists $cfg $type] && [string length [dict get $cfg $type]] > 0 } {
lappend content [::tcltm::markup::nl]
lappend content [::tcltm::markup::comment "TCLTM [string toupper $type] BEGIN"]
if { [llength [split [dict get $cfg $type] "\n"]] == 1 } {
if { [string match "*.tcl" [lindex [split [dict get $cfg $type] "\n"] 0]] } {
set bfile [lindex [split [dict get $cfg $type] "\n"] 0]
foreach line [split [::tcltm::binary::readfile [dict get $config options in] [::tcltm::binary::filename [dict get $config options in] $bfile]] "\n"] {
if { [dict get $config options strip] && [::tcltm::markup::iscomment $line] } {
} else {
foreach elm $filter {
set k [lindex $elm 0]
set v [lindex $elm 1]
set line [::tcltm::filter::line $line $k "$v"]
}
lappend content $line
}
}
} else {
lappend content [::tcltm::markup::script [dict get $cfg $type]]
}
} else {
foreach line [split [dict get $cfg $type] "\n"] {
if { [dict get $config options strip] && [::tcltm::markup::iscomment $line] } {
} else {
foreach elm $filter {
set k [lindex $elm 0]
set v [lindex $elm 1]
set line [::tcltm::filter::line $line $k $v]
}
lappend content [::tcltm::markup::script $line]
}
}
}
lappend content [::tcltm::markup::comment "TCLTM [string toupper $type] END"]
}
return -code ok
}
proc code { pkg } {
variable config
variable content
variable cfg [pkgcfg $pkg]
lappend content [::tcltm::markup::nl]
lappend content [::tcltm::markup::comment "TCLTM SCRIPT SECTION BEGIN"]
foreach f [dict get $cfg files] {
set inc 0
if { [file extension [::tcltm::binary::filename [dict get $config options in] [dict get $f name]]] eq ".tcl" } {
set inc 1
} elseif { [dict exists $f type] && [string tolower [dict get $f type]] eq "script" } {
set inc 1
}
set filter [list]
if { [dict exists $f filtering] && [dict get $f filtering] } {
set filter {*}[::tcltm::filter::lfile $cfg [dict get $f name]]
lappend filter "PNAME [dict get $cfg name]"
if { [dict exists $cfg version] } {
lappend filter "PVERSION \"[dict get $cfg version]\""
}
lappend filter "FILENAME [dict get $f name]"
}
if { $inc } {
set ignore(block) 0
set ignore(next) 0
foreach line [split [::tcltm::binary::readfile [dict get $config options in] [dict get $f name]] "\n"] {
if { [string match {*TCLTM*IGNORE*BEGIN*} [string toupper $line]] } {
set ignore(block) 1
continue
}
if { [string match {*TCLTM*IGNORE*END*} [string toupper $line]] } {
set ignore(block) 0
continue
}
if { $ignore(block) } {
continue
}
if { [string match {*TCLTM*IGNORE*NEXT*} [string toupper $line]] } {
set ignore(next) 1
continue
}
if { $ignore(next) } {
set ignore(next) 0
continue
}
if { [string match {*TCLTM*IGNORE*} [string toupper $line]] } {
continue
}
if { [dict get $config options strip] && [::tcltm::markup::iscomment $line] } {
} else {
if { ![regexp {^(?:([[:blank:]]+)?)package provide*} $line] } {
if { ![dict get $config options preserve-require] && [regexp {^(?:([[:blank:]]+)?)package require*} $line] } {
}
if { [dict exists $f filtering] && [dict get $f filtering] } {
foreach elm $filter {
set k [lindex $elm 0]
set v [lindex $elm 1]
set line [::tcltm::filter::line $line $k $v]
}
}
lappend content $line
}
}
}
}
}
lappend content [::tcltm::markup::comment "TCLTM SCRIPT SECTION END"]
return -code ok
}
proc pkg-provide { pkg } {
variable config
variable content
variable cfg [pkgcfg $pkg]
if { ![dict get $config options exclude-provide] } {
if { [dict exists $cfg version] } {
lappend content [::tcltm::markup::nl]
lappend content [::tcltm::markup::script {package provide %s %s} [dict get $cfg name] [dict get $cfg version]]
} else {
puts stdout "Skipping Package Provide due to missing version information"
}
}
return -code ok
}
proc binaryloader { pkg } {
variable config
variable content
variable cfg [pkgcfg $pkg]
if { [::tcltm::binary::present [dict get $cfg files]] } {
lappend content [::tcltm::markup::nl]
lappend content [::tcltm::markup::comment "TCLTM BINARY LOADER BEGIN"]
lappend content [::tcltm::markup::script $::tcltm::loader::script]
if { [dict get $config options interactive-loader] } {
lappend content [::tcltm::markup::script $::tcltm::loader::interactive]
} else {
lappend content [::tcltm::markup::script $::tcltm::loader::action]
}
lappend content [::tcltm::markup::comment "TCLTM BINARY LOADER END"]
}
return -code ok
}
}
namespace eval ::tcltm {
proc scan { args } {
set results [dict create]
set f [file normalize [lindex $args 0]]
if { ![file exists $f] } {
puts stdout "File '$f' does not exists"
exit 1
}
set files $f
if { [file isdirectory $f] } {
set files [glob -nocomplain -directory $f -types f -- *.tcl]
}
foreach f $files {
set res [dict create]
set b [open $f]
fconfigure $b -translation binary
fconfigure $b -encoding binary
set data [read $b]
close $b
set pkgs [list]
foreach line [split $data "\n"] {
set r [dict create]
if { [regexp {package (provide|require|ifneeded)(?:[[:blank:]]+)([_[:alpha:]][:_[:alnum:]]*)(?:\])?((?:[[:blank:]]+)?(?:(\d+\.)?(\d+\.)?(\*|\d+))?)} $line -> type pkg ver] } {
dict set r type $type
dict set r package $pkg
dict set r version [string trim $ver]
lappend pkgs $r
}
}
dict set results $f $pkgs
}
return $results
}
}
namespace eval ::tcltm {
variable version
variable commit
proc usage {} {
puts stdout [subst {
NAME:
tcltm - Tcl Module Builder
USAGE:
tcltm ?options?
VERSION:
$::tcltm::version ($::tcltm::commit)
OPTIONS:
-i DIR, --in DIR Input directory. (Defaults: current directory)
-o DIR, --out DIR Output directory. (Defaults: current directory)
-c FILE, --config FILE Alternate config file. (Defaults: .tcltm)
-p NAME, --pkg NAME Only build package <NAME> from config.
(Defaults: build all)
--version-from-index Use package version from pkgIndex.tcl
Only works when package name between config and
pkgIndex.tcl is the same.
--strip-comments Strip comments from source
--strip-resource-dir Strip the directory from the source files.
--exclude-satisfy-tcl Exclude Tcl vsatisfies command
--exclude-deps Exclude package require commands for dependencies
--exclude-provide Exclude package provide command
--preserve-require Preserve 'package require' in source code.
--interactive-loader Enable interactive loader.
Interactive loader will only run the binary loader when
the tcl interpreter is in interactive mode.
--repository Create repository output directories.
(tcl8/tcl<version>/module.tm)
--scan FILE Scan FILE for Tcl dependencies.
If file is a directory, all .tcl files in the
directory will be scanned.
--verbose Verbose logging
--version Show version
-h, --help Show help
}]
}
proc main { args } {
array set options {
in {}
out {}
config {.tcltm}
pkg {}
strip 0
strip-resource-dir 0
version-from-index 0
exclude-satisfy-tcl 0
exclude-deps 0
exclude-provide 0
preserve-require 0
interactive-loader 0
repo 0
scan {}
verbose 0
help 0
version 0
}
while { [llength $args] } {
switch -glob -- [lindex $args 0] {
-i -
--in {set args [lassign $args - options(in)]}
-o -
--out {set args [lassign $args - options(out)]}
-c -
--config {set args [lassign $args - options(config)]}
-p -
--pkg {set args [lassign $args - options(pkg)]}
--version-from-index {set options(version-from-index) 1; set args [lrange $args 1 end]}
--strip-comments {set options(strip) 1; set args [lrange $args 1 end]}
--strip-resource-dir {set options(strip-resource-dir) 1; set args [lrange $args 1 end]}
--exclude-satisfy-tcl {set options(exclude-satisfy-tcl) 1; set args [lrange $args 1 end]}
--exclude-deps {set options(exclude-deps) 1; set args [lrange $args 1 end]}
--exclude-provide {set options(exclude-provide) 1; set args [lrange $args 1 end]}
--preserve-require {set options(preserve-require) 1; set args [lrange $args 1 end]}
--repository {set options(repo) 1; set args [lrange $args 1 end]}
--interactive-loader {set options(interactive-loader) 1; set args [lrange $args 1 end]}
--scan {set args [lassign $args - options(scan)]}
--verbose {set options(verbose) 1; set args [lrange $args 1 end]}
--version {set options(version) 1; set args [lrange $args 1 end]}
-h -
--help {set options(help) 1; set args [lrange $args 1 end]}
-- {set args [lrange $args 1 end]; break}
-* {puts stdout "Unknown option [lindex $args 0]"; exit 1}
default {break}
}
}
# Show version
if { $options(version) } {
puts stdout "$::tcltm::version ($::tcltm::commit)"; flush stdout
exit 0
}
# Show help is requested
if { $options(help) } {
usage
exit 1
}
# Scan for dependencies
if { [string length $options(scan)] > 0 } {
set res [::tcltm::scan {*}$options(scan)]
foreach {f r} $res {
puts stdout "File: $f"
foreach p $r {
puts stdout " Type: [dict get $p type]"
puts stdout " Package: [dict get $p package]"
puts stdout " Version: [dict get $p version]\n"
}
}
exit 0
}
# input/output directory validation
foreach dir {in out} {
if { [string length $options($dir)] == 0 } {
set options($dir) [file normalize [pwd]]
if { $options(verbose) } {
puts stdout "No ${dir}put directory provided"
puts stdout " => Using current working directory \[[file normalize [pwd]]\]"
flush stdout
}
} else {
if { ![file isdirectory $options($dir)] } {
puts stdout "$options($dir) is not a directory"; exit 1
}
}
}
# Locate configuration
if { ![::tcltm::config::exists $options(in) $options(config)] } {
puts stdout "Missing configuration: $options(config)"; exit 1
}
# Load configuration and merge with commandline options
if { $options(verbose) } { puts stdout "Loading Configuration" }
set config [::tcltm::config::load $options(in) $options(config)]
set config [::tcltm::config::merge $config [array get options]]
set config [::tcltm::config::parse $config]
if { $options(verbose) } { puts stdout $config }
# Compile all packages wihtin configuration
foreach p [dict get $config package] {
set pkg [dict get $p name]
if { [string length $options(pkg)] > 0 } {
if { $pkg ne $options(pkg) } {
continue
}
}
puts stdout "Building: $pkg"
# New Module
::tcltm::module::new $config $pkg
# Handle LICENSE
::tcltm::module::license $pkg
# Module Header
::tcltm::module::header $pkg
# Module Satify Tcl Version
::tcltm::module::satisfy-tcl-version $pkg
# Module Dependencies
::tcltm::module::deps $pkg
# Module Bootstrap
::tcltm::module::script $pkg bootstrap
# Binary Loader
::tcltm::module::binaryloader $pkg
# Module Source Code
::tcltm::module::code $pkg
# Module Init Script
::tcltm::module::script $pkg init
# Module Provide
::tcltm::module::pkg-provide $pkg
# Module Finalize
::tcltm::module::script $pkg finalize
# Write Module
::tcltm::module::write $pkg
}
}
}
::tcltm::main {*}$::argv

93
src/scriptapps/wrappers/README.md
Unescape View File

@ -0,0 +1,93 @@
These wrappers are intended to be used with the pmix wrapper functions to automate wrapping of tcl,sh,powershell scripts into a polyglot script which will run in multiple environments
You may also use these to hand-craft polyglot scripts.
To override the default wrapper provided by the pmix command - you can create copies of the sample_ files and remove just the sample_ part
pmix wrap will then never wrap with latest version from the punk project - but only what you have in your scriptapps/wrappers folder.
Alternatively you can copy the sample_ files and name them anything you like that doesn't begin with "punk-"
Then you can call the pmix wrap functions with the -template option and just the name of your file.
(only the scriptapps/wrappers folder will be used to locate your template)
You can create a yourscriptname.wrapconf file in the scriptapps folder alongside yourscriptname.tcl, yourscriptname.sh etc
This .wrapconf is only required if you need to do more complex wrapping.
By default, with no yourscriptname.wrapconf found:
yourscriptname.tcl will be substituted between
#<tcl-payload>
#</tcl-payload>
yourscriptname.sh (if present) will be substituted between
#<shell-payload-pre-tcl>
#</shell-payload-pre-tcl>
yourscriptname.ps1 (if present) will be substituted between
#<powershell-payload-pre-tcl>
#</powershell-payload-pre-tcl>
By providing a yourscriptname.wrapconf
you can specify the exact names of the files (in the scriptapps folder) that you want to include - and use more tags such as:
#<shell-launch-tcl>
#</shell-launch-tcl>
#<shell-payload-post-tcl>
#</shell-payload-post-tcl>
#<powershell-launch-tcl>
#/<powershell-launch-tcl>
#<powershell-payload-post-tcl>
#</powershell-payload-post-tcl>
The .wrapconf file can have comment lines (beginning with # and possibly whitespace)
e.g myutility.wrapconf might contain:
#------------------------
tagdata <shell-payload-pre-tcl> file myutility_download-tclkit2.sh
tagdata <shell-launch-tcl> file myutility_launch-with-tclkit2.sh
tagdata <powershell-payload-pre-tcl> file myutility_download-tclkit2.ps1
tagdata <powershell-launch-tcl> file myutility_launch-with-tclkit2.ps1
#------------------------
Where tagdata command uses the specified file contents to replace all the lines between the starting tag and corresponding closing tag
It is an error to use the tagdata command on a self-closing tag (aka 'singleton' tag - such as <tag/> vs a paired set <tag> .. </tag>
paired tags must have their opening and closing tags on different lines.
hence the following line is invalid.
# <mytag> something etc </mytag> # etc
This is because system is designed to allow repeated updates and analysis of existing output files.
i.e Tags are only supported in places where the languages will accept/ignore them (generally as part of comments)
This means it should be possible to reliably detect which template was used and when template upgrades/fixes can be safely applied in the presence of possibly tweaked non-template script data.
Possible exceptions are cases where 2 templates differ only in the default data on singleton-tag lines or default data between paired tags, and that default data has been replaced.
There are of course other more flexible/standard methods (e.g diff) to achieve this sort of thing - but this method was chosen to provide more explicit readability of where the insertion points are.
singleton or paired tags can be replaced.
Failing to include the tag in the resultant line results in an error.
#------------------------
#replacement of a singleton tag
tagline <batch-nextshell-line/> line {@set "nextshell=tclsh" & :: @<batch-nextshell-line/>}
#replacement of closing tag of a paired-tag
tagline </powershell-launch-tcl> line {#</powershell-launch-tcl> some comment or data}
#------------------------
The .wrapconf could also specify a specific template in your scriptapps/wrappers folder e.g:
#------------------------
template myutility-multishell.cmd
#------------------------
Leave template line out, or specify the defaults if you want to use the wrappers from the punk shell you are using. e.g
#------------------------
template punk-multishell.cmd
#------------------------

264
src/scriptapps/wrappers/sample_punk-multishell.cmd
Unescape View File

@ -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"
# -- --- --- --- --- --- --- --- --- --- --- ---
#<tcl-payload>
#</tcl-payload>
# -- --- --- --- --- --- --- --- --- --- --- ---
# -- 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"
#<shell-payload-pre-tcl>
#</shell-payload-pre-tcl>
# -- --- --- --- --- --- --- ---
#<shell-launch-tcl>
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
#</shell-launch-tcl>
# -- --- --- --- --- --- --- ---
#<shell-payload-post-tcl>
#</shell-payload-post-tcl>
#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
# -- --- --- ---
#<powershell-payload-pre-tcl>
#</powershell-payload-pre-tcl>
# -- --- --- --- --- --- --- ---
#<powershell-launch-tcl>
tclsh $scriptname $args
#</powershell-launch-tcl>
# -- --- --- --- --- --- --- ---
#<powershell-payload-post-tcl>
#</powershell-payload-post-tcl>
# 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
# <ctrl-z>

# </ctrl-z>
# -- unreachable by tcl directly if ctrl-z character is in the <ctrl-z> 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)
#>

112
src/scriptapps/wrappers/sample_punk-shellbat.bat
Unescape View File

@ -0,0 +1,112 @@
: "[proc : args {}]" ;# *tcl shellbat - call with sh,bash,tclsh on any platform, or with cmd on windows.
: <<'HIDE_FROM_BASH_AND_SH'
: ;# leading colon hides from .bat, trailing slash hides next line from tcl \
@call tclsh "%~dp0%~n0.bat" %*
: ;#\
@set taskexitcode=%errorlevel% & goto :exit
# -*- tcl -*-
# #################################################################################################
# This is a tcl shellbat file
# It is tuned to run when called as a batch file, a tcl script, an sh script or a bash script,
# so the specific layout and characters used are quite sensitive to change.
# It can be called on unix or windows platforms with or without the interpreter being specified on the commandline.
# e.g ./filename.sh.bat in sh or bash or powershell
# e.g filename.sh or filename.sh.bat at windows command prompt
# e.g tclsh filename.sh.bat | sh filename.sh.bat | bash filename.sh.bat
# In all cases an arbitrary number of arguments are accepted
# To avoid the initial commandline on stdout when calling as a batch file on windows, use:
# cmd /Q /c filename.sh.bat
# (because we cannot use @if to silence it, as this isn't understood by tcl,sh or bash)
# #################################################################################################
#fconfigure stdout -translation crlf
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl Payload
#puts "script : [info script]"
#puts "argcount : $::argc"
#puts "argvalues: $::argv"
#<tcl-payload>
#<tcl-payload/>
# --- --- --- --- --- --- --- --- --- --- --- --- ---
# only exit if needed. see exitcode notes at bottom of file and exit there for consistency across invocation methods
# --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl Payload
#--
#-- bash/sh code follows.
#-- protect from tcl using line continuation char on the previous comment for each line, like so: \
printf "etc"
#-- or alternatively place sh/bash script within the false==false block
#-- whilst being careful to balance braces {}
#-- For more complex needs you should call out to external scripts
#--
#-- END marker for hide_from_bash_and_sh\
HIDE_FROM_BASH_AND_SH
#---------------------------------------------------------
#-- This if statement hides(mostly) a sh/bash code block from Tcl
if false==false # else {
then
:
#---------------------------------------------------------
#-- leave as is if all that's required is launching the Tcl payload"
#--
#-- Note that sh/bash script isn't called when running a .bat from cmd.exe on windows by default
#-- adjust line 4: @call tclsh ... to something like @call sh ... @call bash .. or @call env sh ... etc as appropriate
#-- if sh/bash scripting needs to run on windows too.
#--
#printf "start of bash or sh code"
#<shell-payload-pre-tcl>
#</shell-payload-pre-tcl>
#-- sh/bash launches Tcl here instead of shebang line at top
#<shell-launch-tcl>
#-- use exec to use exitcode (if any) directly from the tcl script
exec /usr/bin/env tclsh "$0" "$@"
#</shell-launch-tcl>
#-- alternative - if sh/bash script required to run after the tcl call.
#/usr/bin/env tclsh "$0" "$@"
#tcl_exitcode=$?
#echo "tcl_exitcode: ${tcl_exitcode}"
#<shell-payload-post-tcl>
#</shell-payload-post-tcl>
#-- override exitcode example
#exit 66
#printf "No need for trailing slashes for sh/bash code here\n"
#---------------------------------------------------------
fi
# closing brace for Tcl }
#---------------------------------------------------------
#-- tcl and shell script now both active
#-- comment for line sample 1 with trailing continuation slash \
#printf "tcl-invisible sh/bash line sample 1 \n"
#-- comment for line sample 2 with trailing continuation slash \
#printf "tcl-invisible sh/bash line sample 2 \n"
#-- Consistent exitcode from sh,bash,tclsh or cmd
#-- Call exit in tcl (or sh/bash) code only if explicitly required, otherwise leave this commented out.
#-- (script might be more widely useable without explicit exit. e.g in tcl: set ::argc 1; set ::argv "val"; source filename.sh.bat )
#-- exit line unprotected by trailing slash will work for tcl and/or sh/bash
#exit 0
#exit 42
#-- make sure sh/bash/tcl all skip over .bat style exit \
: <<'shell_end'
#-- .bat exit with exitcode from tcl process \
:exit
: ;# \
@exit /B %taskexitcode%
# .bat has exited \
shell_end

200
src/vendormodules/cksum-1.1.4.tm
Unescape View File

@ -0,0 +1,200 @@
# cksum.tcl - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# Provides a Tcl only implementation of the unix cksum(1) command. This is
# similar to the sum(1) command but the algorithm is better defined and
# standardized across multiple platforms by POSIX 1003.2/D11.2
#
# This command has been verified against the cksum command from the GNU
# textutils package version 2.0
#
# -------------------------------------------------------------------------
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -------------------------------------------------------------------------
package require Tcl 8.5-; # tcl minimum version
namespace eval ::crc {
namespace export cksum
variable cksum_tbl [list 0x0 \
0x04C11DB7 0x09823B6E 0x0D4326D9 0x130476DC 0x17C56B6B \
0x1A864DB2 0x1E475005 0x2608EDB8 0x22C9F00F 0x2F8AD6D6 \
0x2B4BCB61 0x350C9B64 0x31CD86D3 0x3C8EA00A 0x384FBDBD \
0x4C11DB70 0x48D0C6C7 0x4593E01E 0x4152FDA9 0x5F15ADAC \
0x5BD4B01B 0x569796C2 0x52568B75 0x6A1936C8 0x6ED82B7F \
0x639B0DA6 0x675A1011 0x791D4014 0x7DDC5DA3 0x709F7B7A \
0x745E66CD 0x9823B6E0 0x9CE2AB57 0x91A18D8E 0x95609039 \
0x8B27C03C 0x8FE6DD8B 0x82A5FB52 0x8664E6E5 0xBE2B5B58 \
0xBAEA46EF 0xB7A96036 0xB3687D81 0xAD2F2D84 0xA9EE3033 \
0xA4AD16EA 0xA06C0B5D 0xD4326D90 0xD0F37027 0xDDB056FE \
0xD9714B49 0xC7361B4C 0xC3F706FB 0xCEB42022 0xCA753D95 \
0xF23A8028 0xF6FB9D9F 0xFBB8BB46 0xFF79A6F1 0xE13EF6F4 \
0xE5FFEB43 0xE8BCCD9A 0xEC7DD02D 0x34867077 0x30476DC0 \
0x3D044B19 0x39C556AE 0x278206AB 0x23431B1C 0x2E003DC5 \
0x2AC12072 0x128E9DCF 0x164F8078 0x1B0CA6A1 0x1FCDBB16 \
0x018AEB13 0x054BF6A4 0x0808D07D 0x0CC9CDCA 0x7897AB07 \
0x7C56B6B0 0x71159069 0x75D48DDE 0x6B93DDDB 0x6F52C06C \
0x6211E6B5 0x66D0FB02 0x5E9F46BF 0x5A5E5B08 0x571D7DD1 \
0x53DC6066 0x4D9B3063 0x495A2DD4 0x44190B0D 0x40D816BA \
0xACA5C697 0xA864DB20 0xA527FDF9 0xA1E6E04E 0xBFA1B04B \
0xBB60ADFC 0xB6238B25 0xB2E29692 0x8AAD2B2F 0x8E6C3698 \
0x832F1041 0x87EE0DF6 0x99A95DF3 0x9D684044 0x902B669D \
0x94EA7B2A 0xE0B41DE7 0xE4750050 0xE9362689 0xEDF73B3E \
0xF3B06B3B 0xF771768C 0xFA325055 0xFEF34DE2 0xC6BCF05F \
0xC27DEDE8 0xCF3ECB31 0xCBFFD686 0xD5B88683 0xD1799B34 \
0xDC3ABDED 0xD8FBA05A 0x690CE0EE 0x6DCDFD59 0x608EDB80 \
0x644FC637 0x7A089632 0x7EC98B85 0x738AAD5C 0x774BB0EB \
0x4F040D56 0x4BC510E1 0x46863638 0x42472B8F 0x5C007B8A \
0x58C1663D 0x558240E4 0x51435D53 0x251D3B9E 0x21DC2629 \
0x2C9F00F0 0x285E1D47 0x36194D42 0x32D850F5 0x3F9B762C \
0x3B5A6B9B 0x0315D626 0x07D4CB91 0x0A97ED48 0x0E56F0FF \
0x1011A0FA 0x14D0BD4D 0x19939B94 0x1D528623 0xF12F560E \
0xF5EE4BB9 0xF8AD6D60 0xFC6C70D7 0xE22B20D2 0xE6EA3D65 \
0xEBA91BBC 0xEF68060B 0xD727BBB6 0xD3E6A601 0xDEA580D8 \
0xDA649D6F 0xC423CD6A 0xC0E2D0DD 0xCDA1F604 0xC960EBB3 \
0xBD3E8D7E 0xB9FF90C9 0xB4BCB610 0xB07DABA7 0xAE3AFBA2 \
0xAAFBE615 0xA7B8C0CC 0xA379DD7B 0x9B3660C6 0x9FF77D71 \
0x92B45BA8 0x9675461F 0x8832161A 0x8CF30BAD 0x81B02D74 \
0x857130C3 0x5D8A9099 0x594B8D2E 0x5408ABF7 0x50C9B640 \
0x4E8EE645 0x4A4FFBF2 0x470CDD2B 0x43CDC09C 0x7B827D21 \
0x7F436096 0x7200464F 0x76C15BF8 0x68860BFD 0x6C47164A \
0x61043093 0x65C52D24 0x119B4BE9 0x155A565E 0x18197087 \
0x1CD86D30 0x029F3D35 0x065E2082 0x0B1D065B 0x0FDC1BEC \
0x3793A651 0x3352BBE6 0x3E119D3F 0x3AD08088 0x2497D08D \
0x2056CD3A 0x2D15EBE3 0x29D4F654 0xC5A92679 0xC1683BCE \
0xCC2B1D17 0xC8EA00A0 0xD6AD50A5 0xD26C4D12 0xDF2F6BCB \
0xDBEE767C 0xE3A1CBC1 0xE760D676 0xEA23F0AF 0xEEE2ED18 \
0xF0A5BD1D 0xF464A0AA 0xF9278673 0xFDE69BC4 0x89B8FD09 \
0x8D79E0BE 0x803AC667 0x84FBDBD0 0x9ABC8BD5 0x9E7D9662 \
0x933EB0BB 0x97FFAD0C 0xAFB010B1 0xAB710D06 0xA6322BDF \
0xA2F33668 0xBCB4666D 0xB8757BDA 0xB5365D03 0xB1F740B4 ]
variable uid
if {![info exists uid]} {set uid 0}
}
# crc::CksumInit --
#
# Create and initialize a cksum context. This is cleaned up when we
# call CksumFinal to obtain the result.
#
proc ::crc::CksumInit {} {
variable uid
set token [namespace current]::[incr uid]
upvar #0 $token state
array set state {t 0 l 0}
return $token
}
proc ::crc::CksumUpdate {token data} {
variable cksum_tbl
upvar #0 $token state
set t $state(t)
binary scan $data c* r
foreach {n} $r {
set index [expr { (($t >> 24) ^ ($n & 0xFF)) & 0xFF }]
# Since the introduction of built-in bigInt support with Tcl
# 8.5, bit-shifting $t to the left no longer overflows,
# keeping it 32 bits long. The value grows bigger and bigger
# instead - a severe hit on performance. For this reason we
# do a bitwise AND against 0xFFFFFFFF at each step to keep the
# value within limits.
set t [expr {0xFFFFFFFF & (($t << 8) ^ [lindex $cksum_tbl $index])}]
incr state(l)
}
set state(t) $t
return
}
proc ::crc::CksumFinal {token} {
variable cksum_tbl
upvar #0 $token state
set t $state(t)
for {set i $state(l)} {$i > 0} {set i [expr {$i>>8}]} {
set index [expr {(($t >> 24) ^ $i) & 0xFF}]
set t [expr {0xFFFFFFFF & (($t << 8) ^ [lindex $cksum_tbl $index])}]
}
unset state
return [expr {~$t & 0xFFFFFFFF}]
}
# crc::Pop --
#
# Pop the nth element off a list. Used in options processing.
#
proc ::crc::Pop {varname {nth 0}} {
upvar $varname args
set r [lindex $args $nth]
set args [lreplace $args $nth $nth]
return $r
}
# Description:
# Provide a Tcl equivalent of the unix cksum(1) command.
# Options:
# -filename name - return a checksum for the specified file.
# -format string - return the checksum using this format string.
# -chunksize size - set the chunking read size
#
proc ::crc::cksum {args} {
array set opts [list -filename {} -channel {} -chunksize 4096 \
-format %u -command {}]
while {[string match -* [set option [lindex $args 0]]]} {
switch -glob -- $option {
-file* { set opts(-filename) [Pop args 1] }
-chan* { set opts(-channel) [Pop args 1] }
-chunk* { set opts(-chunksize) [Pop args 1] }
-for* { set opts(-format) [Pop args 1] }
-command { set opts(-command) [Pop args 1] }
default {
if {[llength $args] == 1} { break }
if {[string compare $option "--"] == 0} { Pop args ; break }
set err [join [lsort [array names opts -*]] ", "]
return -code error "bad option \"option\": must be $err"
}
}
Pop args
}
if {$opts(-filename) != {}} {
set opts(-channel) [open $opts(-filename) r]
fconfigure $opts(-channel) -translation binary
}
if {$opts(-channel) == {}} {
if {[llength $args] != 1} {
return -code error "wrong # args: should be\
cksum ?-format string?\
-channel chan | -filename file | string"
}
set tok [CksumInit]
CksumUpdate $tok [lindex $args 0]
set r [CksumFinal $tok]
} else {
set tok [CksumInit]
while {![eof $opts(-channel)]} {
CksumUpdate $tok [read $opts(-channel) $opts(-chunksize)]
}
set r [CksumFinal $tok]
if {$opts(-filename) != {}} {
close $opts(-channel)
}
}
return [format $opts(-format) $r]
}
# -------------------------------------------------------------------------
package provide cksum 1.1.4
# -------------------------------------------------------------------------
# Local variables:
# mode: tcl
# indent-tabs-mode: nil
# End:

8
src/vendormodules/natsort-0.1.1.5.tm
Unescape View File

@ -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
}]

Write Preview
Loading…
Cancel
Save