From 24c788b646a5aed964f0cbd0705cc1a5425df73f Mon Sep 17 00:00:00 2001
From: Julian Noble <julian@precisium.com.au>
Date: Thu, 30 Jan 2025 19:22:32 +1100
Subject: [PATCH] punk::args fixes, package override check of info loaded
---
src/bootsupport/modules/funcl-0.1.tm | 13 +-
src/bootsupport/modules/modpod-0.1.2.tm | 23 +-
src/bootsupport/modules/punk-0.1.tm | 19 +-
src/bootsupport/modules/punk/args-0.1.0.tm | 293 +++++---
src/bootsupport/modules/punk/lib-0.1.1.tm | 2 +-
src/bootsupport/modules/punk/mix/cli-0.3.1.tm | 68 +-
.../modules/punk/mix/commandset/doc-0.1.0.tm | 2 +-
src/bootsupport/modules/punk/ns-0.1.0.tm | 2 +-
.../modules/punk/packagepreference-0.1.0.tm | 88 ++-
.../modules/punk/repl/codethread-0.1.1.tm | 9 +-
src/bootsupport/modules/punk/zip-0.1.1.tm | 48 +-
src/bootsupport/modules/textblock-0.1.3.tm | 204 ++++--
src/bootsupport/modules/zipper-0.12.tm | Bin 9846 -> 9847 bytes
.../zipper-999999.0a1.0.tm | 4 +-
.../#tarjar-loadscript-tarjar.tcl | 8 +-
src/modules/funcl-0.1.tm | 13 +-
src/modules/punk-0.1.tm | 19 +-
src/modules/punk/args-999999.0a1.0.tm | 293 +++++---
src/modules/punk/args/tclcore-999999.0a1.0.tm | 242 ++++++-
src/modules/punk/lib-999999.0a1.0.tm | 2 +-
src/modules/punk/mix/cli-999999.0a1.0.tm | 29 +-
.../punk/mix/commandset/doc-999999.0a1.0.tm | 2 +-
src/modules/punk/ns-999999.0a1.0.tm | 2 +-
.../punk/packagepreference-999999.0a1.0.tm | 88 ++-
src/modules/punk/repl-0.1.tm | 4 +-
.../punk/repl/codethread-999999.0a1.0.tm | 9 +-
src/modules/punk/safe-999999.0a1.0.tm | 17 +-
src/modules/punk/zip-999999.0a1.0.tm | 48 +-
src/modules/shellthread-1.6.1.tm | 3 +
src/modules/textblock-999999.0a1.0.tm | 204 ++++--
.../src/bootsupport/modules/funcl-0.1.tm | 13 +-
.../src/bootsupport/modules/modpod-0.1.2.tm | 23 +-
.../src/bootsupport/modules/punk-0.1.tm | 19 +-
.../bootsupport/modules/punk/args-0.1.0.tm | 293 +++++---
.../src/bootsupport/modules/punk/lib-0.1.1.tm | 2 +-
.../bootsupport/modules/punk/mix/cli-0.3.1.tm | 68 +-
.../modules/punk/mix/commandset/doc-0.1.0.tm | 2 +-
.../src/bootsupport/modules/punk/ns-0.1.0.tm | 2 +-
.../modules/punk/packagepreference-0.1.0.tm | 88 ++-
.../modules/punk/repl/codethread-0.1.1.tm | 9 +-
.../src/bootsupport/modules/punk/zip-0.1.1.tm | 48 +-
.../bootsupport/modules/textblock-0.1.3.tm | 204 ++++--
.../src/bootsupport/modules/zipper-0.12.tm | Bin 9846 -> 9847 bytes
.../src/bootsupport/modules/funcl-0.1.tm | 13 +-
.../src/bootsupport/modules/modpod-0.1.2.tm | 23 +-
.../src/bootsupport/modules/punk-0.1.tm | 19 +-
.../bootsupport/modules/punk/args-0.1.0.tm | 293 +++++---
.../src/bootsupport/modules/punk/lib-0.1.1.tm | 2 +-
.../bootsupport/modules/punk/mix/cli-0.3.1.tm | 68 +-
.../modules/punk/mix/commandset/doc-0.1.0.tm | 2 +-
.../src/bootsupport/modules/punk/ns-0.1.0.tm | 2 +-
.../modules/punk/packagepreference-0.1.0.tm | 88 ++-
.../modules/punk/repl/codethread-0.1.1.tm | 9 +-
.../src/bootsupport/modules/punk/zip-0.1.1.tm | 48 +-
.../bootsupport/modules/textblock-0.1.3.tm | 204 ++++--
.../src/bootsupport/modules/zipper-0.12.tm | Bin 9846 -> 9847 bytes
src/vendormodules/modpod-0.1.2.tm | 23 +-
src/vendormodules/packagetrace-0.8.tm | 2 +-
src/vendormodules/packagetrace-0.9.tm | 643 ++++++++++++++++++
src/vfs/_vfscommon.vfs/modules/funcl-0.1.tm | 13 +-
.../_vfscommon.vfs/modules/modpod-0.1.2.tm | 23 +-
.../modules/packagetrace-0.8.tm | 2 +-
.../modules/packagetrace-0.9.tm | 643 ++++++++++++++++++
src/vfs/_vfscommon.vfs/modules/punk-0.1.tm | 19 +-
.../_vfscommon.vfs/modules/punk/args-0.1.0.tm | 293 +++++---
.../modules/punk/args/tclcore-0.1.0.tm | 242 ++++++-
.../_vfscommon.vfs/modules/punk/lib-0.1.1.tm | 2 +-
.../modules/punk/mix/cli-0.3.1.tm | 29 +-
.../modules/punk/mix/commandset/doc-0.1.0.tm | 2 +-
.../_vfscommon.vfs/modules/punk/ns-0.1.0.tm | 2 +-
.../modules/punk/packagepreference-0.1.0.tm | 88 ++-
.../_vfscommon.vfs/modules/punk/repl-0.1.tm | 4 +-
.../modules/punk/repl/codethread-0.1.1.tm | 9 +-
.../_vfscommon.vfs/modules/punk/safe-0.1.0.tm | 17 +-
.../_vfscommon.vfs/modules/punk/zip-0.1.1.tm | 48 +-
.../modules/shellthread-1.6.1.tm | 3 +
.../_vfscommon.vfs/modules/textblock-0.1.3.tm | 204 ++++--
src/vfs/_vfscommon.vfs/modules/zipper-0.12.tm | Bin 9846 -> 9847 bytes
78 files changed, 4432 insertions(+), 1179 deletions(-)
create mode 100644 src/vendormodules/packagetrace-0.9.tm
create mode 100644 src/vfs/_vfscommon.vfs/modules/packagetrace-0.9.tm
diff --git a/src/bootsupport/modules/funcl-0.1.tm b/src/bootsupport/modules/funcl-0.1.tm
index ccdc9d99..1d2fe64a 100644
--- a/src/bootsupport/modules/funcl-0.1.tm
+++ b/src/bootsupport/modules/funcl-0.1.tm
@@ -64,16 +64,19 @@ namespace eval funcl {
set posn [lsearch $cmdlist _]
if {$posn <= 0} {
append body $cmdlist
- if {$i == [expr {[llength $args] -2}]} {
- #append body " \$data"
+ if {$i == ([llength $args]-2)} {
append body " $wrap"
}
+ #if {$i == [expr {[llength $args] -2}]} {
+ # #append body " \$data"
+ # append body " $wrap"
+ #}
if {$i > 0} {
set t {]}
}
} else {
append body [lrange $cmdlist 0 $posn-1]
- if {$i == [expr {[llength $args] -2}]} {
+ if {$i == ([llength $args] -2)} {
#append body " \$data"
append body " $wrap"
}
@@ -291,7 +294,7 @@ namespace eval funcl {
set posn [lsearch $cmdlist _]
if {$posn <= 0} {
append body $cmdlist
- if {$i == [expr {[llength $args] -1}]} {
+ if {$i == ([llength $args] -1)} {
append body " \$data"
}
if {$i > 0} {
@@ -299,7 +302,7 @@ namespace eval funcl {
}
} else {
append body [lrange $cmdlist 0 $posn-1]
- if {$i == [expr {[llength $args] -1}]} {
+ if {$i == ([llength $args] -1)} {
append body " \$data"
}
set t [lrange $cmdlist $posn+1 end]
diff --git a/src/bootsupport/modules/modpod-0.1.2.tm b/src/bootsupport/modules/modpod-0.1.2.tm
index 166bd423..aa27ebce 100644
--- a/src/bootsupport/modules/modpod-0.1.2.tm
+++ b/src/bootsupport/modules/modpod-0.1.2.tm
@@ -135,9 +135,10 @@ namespace eval modpod {
proc connect {args} {
puts stderr "modpod::connect--->>$args"
set argd [punk::args::get_dict {
+ @id -id ::modpod::connect
-type -default ""
- *values -min 1 -max 1
- path -type string -minlen 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)"
+ @values -min 1 -max 1
+ path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)"
} $args]
catch {
punk::lib::showdict $argd ;#heavy dependencies
@@ -329,14 +330,16 @@ namespace eval modpod::lib {
#zipfile is a pure zip at this point - ie no script/exe header
proc make_zip_modpod {args} {
set argd [punk::args::get_dict {
- -offsettype -default "archive" -choices {archive file} -help "Whether zip offsets are relative to start of file or start of zip-data within the file.
- 'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip,
- but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip)
- info-zip's 'zip -A' can sometimes convert archive-relative to file-relative.
- -offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'"
- *values -min 2 -max 2
- zipfile -type path -minlen 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries"
- outfile -type path -minlen 1 -help "path to output file. Name should be of the form packagename-version.tm"
+ @id -id ::modpod::lib::make_zip_modpod
+ -offsettype -default "archive" -choices {archive file} -help\
+ "Whether zip offsets are relative to start of file or start of zip-data within the file.
+ 'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip,
+ but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip)
+ info-zip's 'zip -A' can sometimes convert archive-relative to file-relative.
+ -offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'"
+ @values -min 2 -max 2
+ zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries"
+ outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm"
} $args]
set zipfile [dict get $argd values zipfile]
set outfile [dict get $argd values outfile]
diff --git a/src/bootsupport/modules/punk-0.1.tm b/src/bootsupport/modules/punk-0.1.tm
index 08359461..738d89c5 100644
--- a/src/bootsupport/modules/punk-0.1.tm
+++ b/src/bootsupport/modules/punk-0.1.tm
@@ -49,6 +49,17 @@ namespace eval punk {
}
set has_commandstack [expr {![catch {package require commandstack}]}]
+ if {$has_commandstack} {
+ if {[catch {
+ package require punk::packagepreference
+ } errM]} {
+ catch {puts stderr "Failed to load punk::packagepreference"}
+ }
+ catch punk::packagepreference::install
+ } else {
+ #
+ }
+
if {![interp issafe] && $has_commandstack && $::tcl_platform(platform) eq "windows"} {
#still a caching version of auto_execok - but with proper(fixed) search order
@@ -353,18 +364,12 @@ punk::aliascore::init
package require punk::repl::codethread
package require punk::config
#package require textblock
-package require punk::console
+package require punk::console ;#requires Thread
package require punk::ns
package require punk::winpath ;# for windows paths - but has functions that can be called on unix systems
package require punk::repo
package require punk::du
package require punk::mix::base
-if {[catch {
- package require punk::packagepreference
-} errM]} {
- puts stderr "Failed to load punk::packagepreference"
-}
-punk::packagepreference::install
namespace eval punk {
# -- --- ---
diff --git a/src/bootsupport/modules/punk/args-0.1.0.tm b/src/bootsupport/modules/punk/args-0.1.0.tm
index 78a18304..37f8b712 100644
--- a/src/bootsupport/modules/punk/args-0.1.0.tm
+++ b/src/bootsupport/modules/punk/args-0.1.0.tm
@@ -332,9 +332,11 @@ tcl::namespace::eval punk::args {
(used for trailing args that come after switches/opts)
%B%@argdisplay%N% ?opt val...?
options -header <str> (text for header row of table)
- -body <str> (text to replace entirety of autogenerated docs)
+ -body <str> (text to replace autogenerated arg info)
%B%@doc%N% ?opt val...?
options -name <str> -url <str>
+ %B%@seealso%N% ?opt val...?
+ options -name <str> -url <str> (for footer - unimplemented)
Some other options normally present on custom arguments are available
to use with the @leaders @opts @values directives to set defaults
@@ -842,7 +844,7 @@ tcl::namespace::eval punk::args {
#id An id will be allocated if no id line present or the -id value is "auto"
if {$DEF_definition_id ne ""} {
#disallow duplicate @id line
- error "punk::args::define - @id already set. Existing value $DEF_definition_id"
+ error "punk::args::define - @id already set. Existing value $DEF_definition_id\n[join $args \n]"
}
if {[dict exists $at_specs -id]} {
set DEF_definition_id [dict get $at_specs -id]
@@ -966,7 +968,7 @@ tcl::namespace::eval punk::args {
-anyopts {
set opt_any $v
}
- -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted {
+ -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted {
#review - only apply to certain types?
tcl::dict::set tmp_optspec_defaults $k $v
}
@@ -1012,7 +1014,7 @@ tcl::namespace::eval punk::args {
tcl::dict::set tmp_optspec_defaults $k $v
}
default {
- set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\
+ set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\
-nominsize -nomaxsize -norange -nochoices -nochoicelabels\
-type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\
-regexprepass -regexprefail -regexprefailmsg -validationtransform\
@@ -1050,7 +1052,7 @@ tcl::namespace::eval punk::args {
}
dict set F $fid LEADER_MAX $v
}
- -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase {
+ -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase {
#review - only apply to certain types?
tcl::dict::set tmp_leaderspec_defaults $k $v
}
@@ -1097,8 +1099,9 @@ tcl::namespace::eval punk::args {
}
default {
set known { -min -minvalues -max -maxvalues\
- -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\
- -nominsize -nomaxsize -norange -nochoices -nochoicelabels\
+ -minsize -maxsize -range\
+ -choices -choicegroups -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\
+ -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\
-type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\
-regexprepass -regexprefail -regexprefailmsg -validationtransform\
}
@@ -1135,7 +1138,7 @@ tcl::namespace::eval punk::args {
}
set val_max $v
}
- -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase {
+ -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase {
#review - only apply to certain types?
tcl::dict::set tmp_valspec_defaults $k $v
}
@@ -1182,7 +1185,9 @@ tcl::namespace::eval punk::args {
}
default {
set known { -min -minvalues -max -maxvalues\
- -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\
+ -minsize -maxsize -range\
+ -choices -choicegroups -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\
+ -nocase\
-nominsize -nomaxsize -norange -nochoices -nochoicelabels\
-type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\
-regexprepass -regexprefail -regexprefailmsg -validationtransform\
@@ -1195,6 +1200,10 @@ tcl::namespace::eval punk::args {
}
}
+ seealso {
+ #todo!
+ #like @doc, except displays in footer, multiple - sub-table?
+ }
default {
error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @argdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id"
}
@@ -1321,7 +1330,9 @@ tcl::namespace::eval punk::args {
}
}
}
- -default - -solo - -range - -choices - -choicegroups - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -minsize - -maxsize - -nocase - -optional - -multiple -
+ -default - -solo - -range -
+ -choices - -choicegroups - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -choiceinfo -
+ -minsize - -maxsize - -nocase - -optional - -multiple -
-validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE -
-regexprepass - -regexprefail - -regexprefailmsg
{
@@ -1528,80 +1539,181 @@ tcl::namespace::eval punk::args {
return $argdata_dict
}
- lappend PUNKARGS [list -dynamic 0 {
- @id -id ::punk::args::get_spec
- @cmd -name punk::args::get_definition -help\
- ""
- id -type string -help\
- "identifer for punk::args defintion
- This will usually be a fully-qualifed
- path for a command name"
- patternlist -type list -optional 1 -default * -help\
- "glob-style patterns for retrieving value or switch
- definitions. If ommitted or passed an empty string,
- the raw unresolved definition will be returned as
- a list, including possible leading flags such as
- -dynamic 0|1.
- If specified as * - the entire definition including
- directive lines will be returned in line form.
- (directives are lines beginning with
- @ e.g @id, @cmd etc)
- "
- override_dict -type dict -optional 1 -default "" -help\
- "unimplemented.
- Will allow overriding or adding flags to a returned
- definition line.
- "
- }]
- #rename get_definition ???
- proc get_spec {id args} {
- lassign $args patternlist override_dict
- if {[llength $args] > 2} {
- punk::args::get_by_id ::punk::args::get_spec [list $id {*}$args]
- return
+ #return raw definition list as created with 'define'
+ proc rawdef {id} {
+ variable argdefcache_by_id
+ set realid [real_id $id]
+ #return the raw definition - possibly with unresolved dynamic parts
+ if {![dict exists $argdefcache_by_id $realid]} {
+ return ""
}
- if {[llength $override_dict] % 2 != 0} {
- #malformed dict
- punk::args::get_by_id ::punk::args::get_spec [list $id {*}$args]
+ return [tcl::dict::get $argdefcache_by_id $realid]
+ }
+
+
+ namespace eval argdoc {
+ variable resolved_def_TYPE_CHOICES {* @id @cmd @leaders @opts @values @doc}
+
+ lappend PUNKARGS [list -dynamic 0 [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES] {
+ @id -id ::punk::args::resolved_def
+ @cmd -name punk::args::resolved_def -help\
+ ""
+ @leaders -min 0 -max 0
+ @opts
+ -form -default 0 -help\
+ "UNIMPLEMENTED
+ Ordinal index or name of command form"
+ -type -default * -choices {%TYPECHOICES%} -choiceprefix 0 -multiple 1
+ -override -type dict -optional 1 -default "" -help\
+ "dict of dicts. Key in outer dict is the name of a
+ directive or an argument. Inner dict is a map of
+ overrides/additions (-<flag> <newval>...) for that line.
+ (unimplemented).
+ "
+ @values -min 1 -max -1
+ id -type string -help\
+ "identifer for a punk::args definition
+ This will usually be a fully-qualifed
+ path for a command name"
+ pattern -type string -optional 1 -default * -multiple 1 -help\
+ "glob-style patterns for retrieving value or switch
+ definitions.
+
+ If -type is * and pattern is * the entire definition including
+ directive lines will be returned in line form.
+ (directives are lines beginning with
+ @ e.g @id, @cmd etc)
+
+ if -type is @leaders,@opts or @values matches from that type
+ will be returned.
+
+ if -type is another directive such as @id, @doc etc the
+ patterns are ignored.
+
+ "
+ }]]
+ }
+
+
+ proc resolved_def {args} {
+ set opts [dict create\
+ -type {}\
+ -form 0\
+ -override {}\
+ ]
+ if {[llength $args] < 1} {
+ #must have at least id
+ punk::args::get_by_id ::punk::args::resolved_def $args
return
}
+ set patterns [list]
+
+ #a definition id must not begin with "-"
+ for {set i 0} {$i < [llength $args]} {incr i} {
+ set a [lindex $args $i]
+ if {$a eq "-type"} {
+ incr i
+ dict lappend opts -type [lindex $args $i]
+ } elseif {[string match -* $a]} {
+ incr i
+ dict set opts $a [lindex $args $i]
+ } else {
+ set id [lindex $args $i]
+ set patterns [lrange $args $i+1 end]
+ break
+ }
+ if {$i == [llength $args]-1} {
+ punk::args::get_by_id ::punk::args::resolved_def $args
+ return
+ }
+ }
+ if {![llength $patterns]} {
+ set patterns [list *]
+ }
+ dict for {k v} $opts {
+ switch -- $k {
+ -form - -type - -override {}
+ default {
+ punk::args::get_by_id ::punk::args::resolved_def $args
+ return
+ }
+ }
+ }
+ set typelist [dict get $opts -type]
+ if {[llength $typelist] == 0} {
+ set typelist {*}
+ }
+ foreach type $typelist {
+ if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} {
+ punk::args::get_by_id ::punk::args::resolved_def $args
+ return
+ }
+ }
variable argdefcache_by_id
set realid [real_id $id]
+
if {$realid ne ""} {
- if {$patternlist eq ""} {
- #return the raw definition - possibly with unresolved dynamic parts
- return [tcl::dict::get $argdefcache_by_id $realid]
- } else {
- set deflist [tcl::dict::get $argdefcache_by_id $realid]
- set result ""
- set specdict [uplevel 1 [list ::punk::args::define {*}$deflist]]
- set arg_info [dict get $specdict ARG_INFO]
- foreach pat $patternlist {
- if {[string match $pat @id]} {
+ set deflist [tcl::dict::get $argdefcache_by_id $realid]
+ set result ""
+ set specdict [uplevel 1 [list ::punk::args::define {*}$deflist]]
+ set arg_info [dict get $specdict ARG_INFO]
+ set argtypes [dict create @opts option @leaders leader @values value]
+ foreach type $typelist {
+ switch -exact -- $type {
+ * {
+ append result \n "@id -id [dict get $specdict id]"
+ append result \n "@cmd [dict get $specdict cmd_info]"
+ append result \n "@doc [dict get $specdict doc_info]"
+ foreach tp {leader option value} {
+ foreach pat $patterns {
+ set matches [dict keys $arg_info $pat]
+ foreach m $matches {
+ set def [dict get $arg_info $m]
+ if {[dict get $def -ARGTYPE] eq $tp} {
+ set def [dict remove $def -ARGTYPE]
+ append result \n "$m $def"
+ }
+ }
+ }
+ }
+
+ }
+ @id {
#only a single id record can exist
append result \n "@id -id [dict get $specdict id]"
}
- if {[string match $pat @cmd]} {
+ @cmd {
#only a single @cmd record can exist
#merged if multiple in original def (?)
append result \n "@cmd [dict get $specdict cmd_info]"
}
- #todo @leaders, @opts, @values lines
- #can be multiple of each. We need to preserve order and interleave
- #with any matching arg_info results.
- #requires storing more info in the internal spec dictionary
- set matches [dict keys $arg_info $pat]
- foreach m $matches {
- set def [dict get $arg_info $m]
- set def [dict remove $def -ARGTYPE]
- append result \n "$m $def"
+ @doc {
+ #only a single @doc record can exist
+ append result \n "@doc [dict get $specdict doc_info]"
+ }
+ @leaders - @opts - @values {
+ #option,
+ foreach pat $patterns {
+ set matches [dict keys $arg_info $pat]
+ foreach m $matches {
+ set def [dict get $arg_info $m]
+ if {[dict get $def -ARGTYPE] eq [dict get $argtypes $type]} {
+ set def [dict remove $def -ARGTYPE]
+ append result \n "$m $def"
+ }
+ }
+ }
+ }
+ default {
}
}
- return $result
}
+
+ return $result
}
}
+
proc get_spec_values {id {patternlist *}} {
variable argdefcache_by_id
set realid [real_id $id]
@@ -1636,13 +1748,14 @@ tcl::namespace::eval punk::args {
#proc get_spec_opts ??
proc get_def {id} {
- if {[id_exists $id]} {
- return [define {*}[get_spec $id]]
- }
+ return [define {*}[rawdef $id]]
+ #if {[id_exists $id]} {
+ # return [define {*}[rawdef $id]]
+ #}
}
proc is_dynamic {id} {
- set spec [get_spec $id]
- return [expr {[lindex $spec 0] eq "-dynamic" && [lindex $spec 1]} ]
+ set deflist [rawdef $id]
+ return [expr {[lindex $deflist 0] eq "-dynamic" && [lindex $deflist 1]} ]
}
variable aliases
@@ -1661,6 +1774,8 @@ tcl::namespace::eval punk::args {
variable aliases
return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $argdefcache_by_id $match]]
}
+
+ #we don't automatically test for (autodef)$id - only direct ids and aliases
proc id_exists {id} {
variable argdefcache_by_id
variable aliases
@@ -1694,6 +1809,9 @@ tcl::namespace::eval punk::args {
return $id
} else {
if {![llength [update_definitions]]} {
+ if {[tcl::dict::exists $argdefcache_by_id (autodef)$id]} {
+ return (autodef)$id
+ }
return ""
} else {
if {[tcl::dict::exists $aliases $id]} {
@@ -1702,6 +1820,9 @@ tcl::namespace::eval punk::args {
if {[tcl::dict::exists $argdefcache_by_id $id]} {
return $id
}
+ if {[tcl::dict::exists $argdefcache_by_id (autodef)$id]} {
+ return (autodef)$id
+ }
return ""
}
}
@@ -1797,7 +1918,7 @@ tcl::namespace::eval punk::args {
@values -min 0 -max 0
}]
proc test_get_dict {args} {
- punk::args::get_dict {*}[punk::args::get_spec ::punk::args::test1] $args
+ punk::args::get_dict {*}[punk::args::rawdef ::punk::args::test1] $args
}
proc test_get_by_id {args} {
punk::args::get_by_id ::punk::args::test1 $args
@@ -2558,7 +2679,7 @@ tcl::namespace::eval punk::args {
mechanism and call this as necessary.
"
-return -default table -choices {string table tableobject}
- } {${[punk::args::get_spec ::punk::args::arg_error -scheme]}} {
+ } {${[punk::args::resolved_def -type @opts ::punk::args::arg_error -scheme]}} {
@values -min 0 -max 1
id -help\
@@ -2568,7 +2689,7 @@ tcl::namespace::eval punk::args {
proc usage {args} {
lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received
set id [dict get $values id]
- set definitionlist [get_spec $id]
+ set definitionlist [rawdef $id]
if {[llength $definitionlist] == 0} {
error "punk::args::usage - no such id: $id"
}
@@ -2589,7 +2710,7 @@ tcl::namespace::eval punk::args {
#deprecate?
proc get_by_id {id arglist} {
- set definitionlist [punk::args::get_spec $id]
+ set definitionlist [punk::args::rawdef $id]
if {[llength $definitionlist] == 0} {
error "punk::args::get_by_id - no such id: $id"
}
@@ -2633,6 +2754,25 @@ tcl::namespace::eval punk::args {
-errorstyle -type string -default enhanced -choices {enhanced standard minimal}
@values -min 3
sep -optional 0 -choices "--"
+
+
+ @form -form withid -synopsis "parse ?-form {int|<formname>...}? ?-errorstyle <choice>? -- withid $id"
+ withid -type literal -help\
+ "The literal value 'withid'"
+ id -type string -help\
+ "id of punk::args definition for a command"
+
+
+ @form -form withdef -synopsis "parse ?-form {int|<formname>...}? ?-errorstyle <choice>? -- withdef $def ?$def?"
+ withdef -type literal -help\
+ "The literal value 'withdef'"
+ def -type string -multiple 1 -optional 0 -help\
+ "Each remaining argument is a block of text
+ defining argument definitions.
+ As a special case, -dynamic <bool> may be
+ specified as the 1st 2 arguments. These are
+ not treated as an indicator to punk::args
+ about how to process the definition."
}]
proc parse {args} {
@@ -2669,7 +2809,8 @@ tcl::namespace::eval punk::args {
return "parse [llength $arglist] args withid $id, options:$opts"
}
withdef {
- if {[llength [lrange $args $split+3 end]] < 1} {
+ set deflist [lrange $args $split+3 end]
+ if {[llength $deflist] < 1} {
error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'"
}
return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts"
@@ -4173,7 +4314,7 @@ tcl::namespace::eval punk::args::lib {
# set PUNKARGS ""
#}
-lappend ::punk::args::register::NAMESPACES ::punk::args ::punk::args::lib
+lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
diff --git a/src/bootsupport/modules/punk/lib-0.1.1.tm b/src/bootsupport/modules/punk/lib-0.1.1.tm
index 353d1f65..1381af87 100644
--- a/src/bootsupport/modules/punk/lib-0.1.1.tm
+++ b/src/bootsupport/modules/punk/lib-0.1.1.tm
@@ -890,7 +890,7 @@ namespace eval punk::lib {
set cur [lmap a_l $list_l { lindex $a_l 0 }]
set list_l [lmap a_l $list_l { lrange $a_l 1 end }]
- if {[join $cur {}] == {}} {
+ if {[join $cur {}] eq {}} {
break
}
lappend zip_l $cur
diff --git a/src/bootsupport/modules/punk/mix/cli-0.3.1.tm b/src/bootsupport/modules/punk/mix/cli-0.3.1.tm
index d9d36291..7d59eb35 100644
--- a/src/bootsupport/modules/punk/mix/cli-0.3.1.tm
+++ b/src/bootsupport/modules/punk/mix/cli-0.3.1.tm
@@ -687,50 +687,34 @@ namespace eval punk::mix::cli {
package require punk::zip
set zipfile $buildfolder/$basename-$module_build_version.zip ;#ordinary zip file (deflate)
- set zipmechanism "punk::zip" ;#todo - get choice of mechanism from config
+ #zipfs mkzip does exactly what we need anyway in this case
+ #unfortunately it's not available in all Tclsh versions we might be running..
+ if {[llength [info commands zipfs]]} {
+ #zipfs mkzip (2025) doesn't add entries for folders.
+ #(Therefore no timestamps)
+ #zip reading utils generally intuit their existence and display them - but often an editor can't add comments to them
+ set wd [pwd]
+ cd $buildfolder
+ puts "zipfs mkzip $zipfile #modpod-$basename-$module_build_version"
+ zipfs mkzip $zipfile #modpod-$basename-$module_build_version
+ cd $wd
- switch -- $zipmechanism {
- "punk::zip" {
- #use -base $buildfolder so that -directory is included in the archive - the modpod stub relies on this - and extraction would be potentially messy otherwise
- punk::zip::mkzip -base $buildfolder -directory $buildfolder/#modpod-$basename-$module_build_version -- $zipfile *
- }
- "zipfs" {
- if {[llength [info commands zipfs]]} {
- #'zipfs mkzip' does we need in this case
- #unfortunately it's not available in all Tclsh versions we might be running..
- #
- #sidenote:
- # as at 2024-10 - zipfs mkimg seems to create an apparently working zip - but on windows not updatable with 'zip -A' or 7z etc
- #This is because offsets are file relative vs archive relative
- #(pkzip & info-zip seem to prefer file-relative ie offsets that have been adjusted after cat headerfile zipfile > somekit
- #this isn't an issue for 'mkzip' here though as we don't yet have a headerfile so offset file vs archive are the same.
-
- set wd [pwd]
- cd $buildfolder
- puts "zipfs mkzip $zipfile #modpod-$basename-$module_build_version"
- zipfs mkzip $zipfile #modpod-$basename-$module_build_version
- cd $wd
- } else {
- #TODO - review punk::zip::mkzip and/or external zip to provide a fallback?
- set had_error 1
- lappend notes "zipfs_unavailable"
- puts stderr "WARNING: zipfs unavailable can't build $modulefile"
- }
- }
- default {
- set had_error 1
- lappend notes "unrecognized_zipmechanism"
- puts stderr "WARNING: no such zipmechanism '$zipmechanism' can't build $modulefile"
- }
- }
-
- if {[catch {package require modpod} errM]} {
- set had_error 1
- lappend notes "modpod_unavailable"
- puts stderr "WARNING: modpod package unavailable can't build $modulefile"
+ } else {
+ #use -base $buildfolder so that -directory is included in the archive - the modpod stub relies on this - and extraction would be potentially messy otherwise
+ #put in an archive-level comment to aid in debugging
+ #punk
+ punk::zip::mkzip -base $buildfolder -directory $buildfolder/#modpod-$basename-$module_build_version -- $zipfile *
+ #punk::zip::mkzip stores permissions - (unix style) - which zipfs mkzip doesn't
+ #Directory ident in zipfs relies on folders ending with trailing slash - if missing, it misidentifies dirs as files.
+ #(ie it can't use permissions/attributes alone to determine directory vs file)
+ #TODO - review punk::zip::mkzip and/or external zip to provide a fallback?
+ #JMN25
+
+ #set had_error 1
+ #lappend notes "zipfs_unavailable"
+ #puts stderr "WARNING: zipfs unavailable can't build $modulefile"
}
-
- if {!$had_error} {
+ if {!$had_error && [file exists $zipfiles]} {
package require modpod
modpod::lib::make_zip_modpod $zipfile $modulefile
}
diff --git a/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm
index 6b1923b1..fa9e8d7c 100644
--- a/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm
+++ b/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm
@@ -22,7 +22,7 @@ package require punk::path ;# for treefilenames, relative
package require punk::repo
package require punk::docgen ;#inline doctools - generate doctools .man files at src/docgen prior to using kettle to producing .html .md etc
package require punk::mix::cli ;#punk::mix::cli::lib used for kettle_call
-#package require punk::mix::util ;#for path_relative
+#package require punkcheck ;#for path_relative
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
diff --git a/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/bootsupport/modules/punk/ns-0.1.0.tm
index 6235224a..8fa9ce89 100644
--- a/src/bootsupport/modules/punk/ns-0.1.0.tm
+++ b/src/bootsupport/modules/punk/ns-0.1.0.tm
@@ -1995,7 +1995,7 @@ tcl::namespace::eval punk::ns {
-return -type string -default table -choices {string table tableobject}
- } {${[punk::args::get_spec ::punk::args::arg_error -scheme]}} {
+ } {${[punk::args::resolved_def -type @opts ::punk::args::arg_error -scheme]}} {
-- -type none -help\
"End of options marker
diff --git a/src/bootsupport/modules/punk/packagepreference-0.1.0.tm b/src/bootsupport/modules/punk/packagepreference-0.1.0.tm
index 5f7dba71..03578a56 100644
--- a/src/bootsupport/modules/punk/packagepreference-0.1.0.tm
+++ b/src/bootsupport/modules/punk/packagepreference-0.1.0.tm
@@ -119,6 +119,7 @@ tcl::namespace::eval punk::packagepreference {
#*** !doctools
#[call [fun install]]
#[para]Override ::package builtin (or the current implementation if it has already been renamed/overridden) to check for and prefer lowercase packages/modules
+ #[para](todo - check info loaded and restrict to existing version as determined from dll/so?)
#[para]The overriding package command will call whatever implementation was in place before install to do the actual work - once it has modified 'package require' names to lowercase.
#[para]This is intended to be in alignment with tip 590 "Recommend lowercase Package Names"
#[para] https://core.tcl-lang.org/tips/doc/trunk/tip/590.md
@@ -152,40 +153,83 @@ tcl::namespace::eval punk::packagepreference {
#despite preference for lowercase - we need to handle packages that insist on providing as uppercase
#(e.g we will still need to handle things like: package provide Tcl 8.6)
#Where the package is already provided uppercase we shouldn't waste time deferring to lowercase
+ set is_exact 0
if {[lindex $args 1] eq "-exact"} {
set pkg [lindex $args 2]
- set vwant [lindex $args 3]
- if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} {
- #although we could shortcircuit using vsatisfies to return the ver
- #we should instead pass through to COMMANDSTACKNEXT so as not to interfere with whatever it does.
- return [$COMMANDSTACKNEXT {*}$args]
-
- #if {$vwant eq "" || [$COMMANDSTACKNEXT vsatisfies $ver $vwant]} {
- # return $ver
- #} else {
- # #package already provided with a different version.. we will defer to underlying implementation to return the standard error
- # return [$COMMANDSTACKNEXT {*}$args]
- #}
- }
+ set vwant [lindex $args 3]-[lindex $args 3]
+ set is_exact 1
} else {
set pkg [lindex $args 1]
- set vwant [lindex $args 2]
- if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} {
- return [$COMMANDSTACKNEXT {*}$args]
- #if {$vwant eq "" || [$COMMANDSTACKNEXT vsatisfies $ver $vwant]} {
- # return $ver
- #}
+ set vwant [lrange $args 2 end] ;#rare - but version can be a list of options
+ if {[llength $vwant] == 1 && [string first - [lindex $vwant 0]] > 0} {
+ #only one version - and it has a dash
+ lassign [split [lindex $vwant 0] -] a b
+ if {$a eq $b} {
+ #string compare version nums (can contain dots and a|b)
+ set is_exact 1
+ }
+ }
+ }
+ if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} {
+ #although we could shortcircuit using vsatisfies to return the ver
+ #we should instead pass through to COMMANDSTACKNEXT so as not to interfere with whatever it does.
+ #e.g a package require logger further down the commandstack
+ return [$COMMANDSTACKNEXT {*}$args]
+ }
+
+ if {!$is_exact && [llength $vwant] <= 1 } {
+ #required version unspecified - or specified singularly
+ # ---------------------------------------------------------------
+ #An attempt to detect dll/so loaded and try to load same version
+ set pkgloadedinfo [lsearch -inline -index 1 [info loaded] $pkg]
+ if {![llength $pkgloadedinfo]} {
+ if {[regexp {[A-Z]} $pkg]} {
+ set pkgloadedinfo [lsearch -inline -index 1 [info loaded] [string tolower $pkg]]
+ if {![llength $pkgloadedinfo]} {
+ set pkgloadedinfo [lsearch -inline -index 1 [info loaded] [string totitle $pkg]]
+ }
+ }
+ }
+
+ if {[llength $pkgloadedinfo]} {
+ puts stderr "--> pkg not present but shared object seems to be loaded: $pkgloadedinfo"
+ lassign $pkgloadedinfo path name
+ set lcpath [string tolower $path]
+ set obj [file tail $lcpath]
+ if {[string match tcl9* $obj]} {
+ set obj [string range $obj 4 end]
+ } elseif {[string match lib* $obj]} {
+ set obj [string range $obj 3 end]
+ }
+ set pkginfo [file rootname $obj]
+ #e.g Thread2.8.8
+ if {[regexp {^([a-zA-Z\-]+)(.*)} $pkginfo _match lname lversion]} {
+ if {[string tolower $lname] eq [string tolower $pkg]} {
+ #name matches pkg
+ #hack for known dll version mismatch
+ if {[string tolower $pkg] eq "thread" && $lversion eq "30b3"} {
+ set lversion 3.0b3
+ }
+ if {[llength $vwant] == 1} {
+ #todo - still check vsatisfies - report a conflict? review
+ }
+ return [$COMMANDSTACKNEXT require $pkg $lversion-$lversion]
+ }
+ }
}
}
+ # ---------------------------------------------------------------
+ set pkgloadedinfo [lsearch -inline -index 1 [info loaded] $pkg]
+
if {[regexp {[A-Z]} $pkg]} {
#only apply catch & retry if there was a cap - otherwise we'll double try for errors unrelated to capitalisation
- if {[catch {$COMMANDSTACKNEXT {*}[string tolower $args]} v]} {
- return [$COMMANDSTACKNEXT {*}$args]
+ if {[catch {$COMMANDSTACKNEXT require [string tolower $pkg] {*}$vwant} v]} {
+ return [$COMMANDSTACKNEXT require $pkg {*}$vwant]
} else {
return $v
}
} else {
- return [$COMMANDSTACKNEXT {*}$args]
+ return [$COMMANDSTACKNEXT require $pkg {*}$vwant]
}
}
default {
diff --git a/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm b/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm
index b3693f71..6158fdce 100644
--- a/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm
+++ b/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm
@@ -137,6 +137,13 @@ tcl::namespace::eval punk::repl::codethread {
variable run_command_cache
+ #Use interp exists instead..
+ #if {[catch {interp children}]} {
+ # #8.6.10 doesn't have it.. when was it introduced?
+ #} else {
+
+ #}
+
proc is_running {} {
variable running
return $running
@@ -150,7 +157,7 @@ tcl::namespace::eval punk::repl::codethread {
#expecting to be called from a thread::send in parent repl - ie in the toplevel interp so that the sub-interp "code" is available
#if a thread::send is done from the commandline in a codethread - Tcl will
- if {"code" ni [interp children] || ![info exists replthread_cond]} {
+ if {![interp exists code] || ![info exists replthread_cond]} {
#in case someone tries calling from codethread directly - don't do anything or change any state
#(direct caller could create an interp named code at the level "" -> "code" -"code" and add a replthread_cond value to avoid this check - but it probably won't do anything useful)
#if called directly - the context will be within the first 'code' interp.
diff --git a/src/bootsupport/modules/punk/zip-0.1.1.tm b/src/bootsupport/modules/punk/zip-0.1.1.tm
index 11ae9ab2..2895b024 100644
--- a/src/bootsupport/modules/punk/zip-0.1.1.tm
+++ b/src/bootsupport/modules/punk/zip-0.1.1.tm
@@ -179,26 +179,55 @@ tcl::namespace::eval punk::zip {
# punk::zip::walk -exclude {CVS/* *~.#*} library
#}]
+ #todo: -relative 0|1 flag?
set argd [punk::args::get_dict {
@id -id ::punk::zip::walk
- @cmd -name punk::zip::walk
+ @cmd -name punk::zip::walk -help\
+ "Walk the directory structure starting at base/<-subpath>
+ and return a list of the files and folders encountered.
+ Resulting paths are relative to base unless -resultrelative
+ is supplied.
+ Folder names will end with a trailing slash.
+ "
+ -resultrelative -optional 1 -help\
+ "Resulting paths are relative to this value.
+ Defaults to the value of base. If empty string
+ is given to -resultrelative the paths returned
+ are effectively absolute paths."
-excludes -default "" -help "list of glob expressions to match against files and exclude"
- -subpath -default ""
+ -subpath -default "" -help\
+ "May contain glob chars for folder elements"
@values -min 1 -max -1
base
fileglobs -default {*} -multiple 1
} $args]
set base [dict get $argd values base]
- set fileglobs [dict get $argd values fileglobs]
+ set fileglobs [dict get $argd values fileglobs]
set subpath [dict get $argd opts -subpath]
set excludes [dict get $argd opts -excludes]
+ set received [dict get $argd received]
set imatch [list]
foreach fg $fileglobs {
lappend imatch [file join $subpath $fg]
}
+ if {![dict exists $received -resultrelative]} {
+ set relto $base
+ set prefix ""
+ } else {
+ set relto [file normalize [dict get $argd opts -resultrelative]]
+ if {$relto ne ""} {
+ if {![Path_a_atorbelow_b $base $relto]} {
+ error "punk::zip::walk base must be at or below -resultrelative value (backtracking not currently supported)"
+ }
+ set prefix [Path_strip_alreadynormalized_prefixdepth $base $relto]
+ } else {
+ set prefix $base
+ }
+ }
+
set result {}
#set imatch [file join $subpath $match]
set files [glob -nocomplain -tails -types f -directory $base -- {*}$imatch]
@@ -210,7 +239,7 @@ tcl::namespace::eval punk::zip {
break
}
}
- if {!$excluded} {lappend result $file}
+ if {!$excluded} {lappend result [file join $prefix $file]}
}
foreach dir [glob -nocomplain -tails -types d -directory $base -- [file join $subpath *]] {
set subdir_entries [walk -subpath $dir -excludes $excludes $base {*}$fileglobs]
@@ -218,7 +247,7 @@ tcl::namespace::eval punk::zip {
#NOTE: trailing slash required for entries to be recognised as 'file type' = "directory"
#This is true for 2024 Tcl9 mounted zipfs at least. zip utilities such as 7zip seem(icon correct) to recognize dirs with or without trailing slash
#Although there are attributes on some systems to specify if entry is a directory - it appears trailing slash should always be used for folder names.
- set result [list {*}$result "$dir/" {*}$subdir_entries]
+ set result [list {*}$result "[file join $prefix $dir]/" {*}$subdir_entries]
}
}
return $result
@@ -554,7 +583,9 @@ tcl::namespace::eval punk::zip {
-comment -default ""\
-help "An optional comment for the archive"
-directory -default ""\
- -help "The new zip archive will scan for contents within this folder or current directory if not provided."
+ -help "The new zip archive will scan for contents within this folder or current directory if not provided.
+ Note that this will
+ "
-base -default ""\
-help "The new zip archive will be rooted in this directory if provided
it must be a parent of -directory or the same path as -directory"
@@ -605,6 +636,7 @@ tcl::namespace::eval punk::zip {
set base $opts(-directory)
set relpath ""
}
+ #will pick up intermediary folders as paths (ending with trailing slash)
set paths [walk -exclude $opts(-exclude) -subpath $relpath -- $base {*}[dict get $argd values globs]]
set norm_filename [file normalize $filename]
@@ -654,6 +686,8 @@ tcl::namespace::eval punk::zip {
}
}
} else {
+ #NOTE that we don't add intermediate folders when creating an archive without using the -directory flag!
+ #ie - only the exact *files* matching the glob are stored.
set paths [list]
set dir [pwd]
if {$opts(-base) ne ""} {
@@ -712,7 +746,7 @@ tcl::namespace::eval punk::zip {
if {$opts(-offsettype) eq "archive"} {
set dataStartOffset [tell $zf] ;#the overall file offset of the start of archive-data //JMN 2024
} else {
- set dataStartOffset 0 ;#offsets relative to file - the zipfs mkzip way :/
+ set dataStartOffset 0 ;#offsets relative to file - the (old) zipfs mkzip way :/
}
set count 0
diff --git a/src/bootsupport/modules/textblock-0.1.3.tm b/src/bootsupport/modules/textblock-0.1.3.tm
index 32450e55..56651d21 100644
--- a/src/bootsupport/modules/textblock-0.1.3.tm
+++ b/src/bootsupport/modules/textblock-0.1.3.tm
@@ -96,42 +96,60 @@ tcl::namespace::eval textblock {
variable use_hash ;#framecache
set use_hash none ;#slightly faster but uglier layout for viewing frame_cache display
- #if {![catch {package require sha1}]} {
- # set use_hash sha1
- #} elseif {![catch {package require md5}]} {
- # set use_hash md5
- #} else {
- # set use_hash none
- #}
- proc use_hash {args} {
- set choices [list none]
- set unavailable [list]
- set pkgs [package names]
- if {"md5" in $pkgs} {
- lappend choices md5
- } else {
- lappend unavailable md5
+ namespace eval argdoc {
+ proc hash_algorithm_choices_and_help {} {
+ set choices [list none]
+ set unavailable [list]
+ set unloaded [dict create]
+ set algorithm_packages {md5 sha1 sha256}
+ foreach p $algorithm_packages {
+ if {[package provide $p] eq ""} {
+ dict set unloaded $p ""
+ }
+ }
+ if {[dict size $unloaded]} {
+ set allpkgs [package names] ;#only retrieve once
+ foreach p $algorithm_packages {
+ if {[dict exists $unloaded $p]} {
+ #not loaded - but check if available
+ if {$p in $allpkgs} {
+ lappend choices $p
+ } else {
+ lappend unavailable $p
+ }
+ } else {
+ lappend choices $p
+ }
+ }
+ } else {
+ lappend choices {*}$algorithm_packages
+ set unavailable ""
+ }
+
+ set choicemsg ""
+ if {[llength $unavailable]} {
+ set choicemsg " (unavailable packages: $unavailable)"
+ }
+ #return $choices
+ return " -choices \{$choices\} -help {algorithm choice $choicemsg} "
}
- if {"sha1" in $pkgs} {
- lappend choices sha1
- } else {
- lappend unavailable sha1
- }
- set choicemsg ""
- if {[llength $unavailable]} {
- set choicemsg " (unavailable packages: $unavailable)"
- }
- set argd [punk::args::get_dict [tstr -return string {
- @id -id ::textblock::use_hash
- @cmd -name "textblock::use_hash" -help\
- "Hashing algorithm to use for framecache lookup.
- 'none' may be slightly faster but less compact
- when viewing textblock::framecache"
- @values -min 0 -max 1
- hash_algorithm -choices {${$choices}} -optional 1 -help\
- "algorithm choice ${$choicemsg}"
- }] $args]
+ }
+
+ # hash_algorithm -optional 1 -choices {${[::textblock::argdoc::hash_algorithm_choices]}} -help\
+ # "algorithm choice"
+
+ punk::args::define -dynamic 1 {
+ @id -id ::textblock::use_hash
+ @cmd -name "textblock::use_hash" -help\
+ "Hashing algorithm to use for framecache lookup.
+ 'none' may be slightly faster but less compact
+ when viewing textblock::framecache"
+ @values -min 0 -max 1
+ hash_algorithm -optional 1 ${[::textblock::argdoc::hash_algorithm_choices_and_help]}
+ }
+ proc use_hash {args} {
+ set argd [punk::args::get_by_id ::textblock::use_hash $args]
variable use_hash
if {![dict exists $argd received hash_algorithm]} {
return $use_hash
@@ -4367,6 +4385,15 @@ tcl::namespace::eval textblock {
"
-return -default table -choices {table tableobject}
+ -table -default "" -type string\
+ -help "existing table object to use"
+ -action -default "append" -choices {append replace}\
+ -help "row insertion method if existing -table is supplied
+ if append is chosen the new values will always start at the first column"
+ -title -type string -help\
+ "Title to display overlayed on top edge of table.
+ Will not be visible if -show_edge is false"
+ -titlealign -type string -choices {left centre right}
-frametype -default "light" -type dict -choices {${$FRAMETYPES}} -choicerestricted 0\
-help "frame type or dict for custom frame"
-show_edge -default "" -type boolean\
@@ -4377,10 +4404,21 @@ tcl::namespace::eval textblock {
-show_hseps -default "" -type boolean\
-help "Show horizontal table separators
(default 0 if no existing -table supplied)"
- -table -default "" -type string\
- -help "existing table object to use"
-colheaders -default "" -type list\
- -help "list of lists. list of column header values. Outer list must match number of columns"
+ -help {list of lists. list of column header values. Outer list must match number of columns.
+ A table
+ e.g single header row: -colheaders {{column_a} {column_b} {column_c}}
+ e.g 2 header rows: -colheaders {{column_a "nextrow test"} {column_b} {column_c}}
+ Note that each element of the outer list is itself a list so:
+ -colheaders {"column a" "column b" "column c"}
+ Is likely not the right format if it was intended to have a single header row where the
+ column titles contain spaces.
+ The correct syntax for that would be:
+ -colheaders {{"column a"} {"column b"} {"column c"}}
+ For spanning header cells - use 'set t [list_as_table -return tableobject ...]'
+ and then something like:
+ $t configure_header 1 -colspans {3 0 0}; $t print
+ }
-header -default "" -type list -multiple 1\
-help "Each supplied -header argument is a header row.
The number of values for each must be <= number of columns"
@@ -4388,9 +4426,6 @@ tcl::namespace::eval textblock {
-help "Whether to show a header row.
Omit for unspecified/automatic,
in which case it will display only if -headers list was supplied."
- -action -default "append" -choices {append replace}\
- -help "row insertion method if existing -table is supplied
- if append is chosen the new values will always start at the first column"
-columns -default "" -type integer\
-help "Number of table columns
Will default to 2 if not using an existing -table object"
@@ -4404,6 +4439,7 @@ tcl::namespace::eval textblock {
set argd [punk::args::get_by_id ::textblock::list_as_table $args]
set opts [dict get $argd opts]
+ set received [dict get $argd received]
set datalist [dict get $argd values datalist]
set existing_table [dict get $opts -table]
@@ -4560,6 +4596,12 @@ tcl::namespace::eval textblock {
}
$t add_row $row
}
+ if {"-title" in $received} {
+ $t configure -title [dict get $opts -title]
+ }
+ if {"-titlealign" in $received} {
+ $t configure -titlealign [dict get $opts -titlealign]
+ }
#puts stdout $rowdata
if {[tcl::dict::get $opts -return] eq "table"} {
set result [$t print]
@@ -5895,7 +5937,16 @@ tcl::namespace::eval textblock {
append out [textblock::join -- $punks $cpunks] \n
set 2frames_a [textblock::join -- [textblock::frame -checkargs 0 $cpunks] [textblock::frame -checkargs 0 $punks]]
append out $2frames_a \n
- set 2frames_b [textblock::join -- [textblock::frame -checkargs 0 -ansiborder $cyanb -title "plainpunks" $punks] [textblock::frame -checkargs 0 -ansiborder $greenb -title "fancypunks" $cpunks]]
+ set 2frames_b [textblock::join --\
+ [textblock::frame -checkargs 0 -ansiborder $cyanb\
+ -title "plainpunks" $punks]\
+ [textblock::frame -checkargs 0 -ansiborder $greenb\
+ -title "fancy"\
+ -titlealign right\
+ -subtitle "punks"\
+ -subtitlealign left\
+ $cpunks]\
+ ]
append out [textblock::frame -checkargs 0 -title "punks" $2frames_b\n$RST$2frames_a] \n
set punkdeck [overtype::right [overtype::left [textblock::frame -checkargs 0 -ansiborder [a+ green bold] -type heavy -title ${redb}PATTERN$RST -subtitle ${redb}PUNK$RST $prightair_cyanb] "$blueb\n\n\P\nU\nN\nK$RST"] "$blueb\n\nD\nE\nC\nK"]
set spantable [[spantest] print]
@@ -7503,20 +7554,41 @@ tcl::namespace::eval textblock {
@id -id ::textblock::frame_cache
@cmd -name textblock::frame_cache -help\
"Display or clear the frame cache."
- -action -default {} -choices {clear} -help\
- "Clear the textblock::frame_cache dictionary"
-pretty -default 1 -help\
- "Use 'pdict textblock::frame_cache */*' for prettier output"
- @values -min 0 -max 0
+ "Uses 'pdict textblock::frame_cache */*' for prettier output
+ Either way this is set, output requires long lines and may
+ still wrap in an ugly manner. Try 'textblock::use_cache md5'
+ to shorten the argument display and reduce wrapping.
+ "
+ @values -min 0 -max 1
+ action -default {display} -choices {clear size info display} -choicelabels {
+ clear "Clear the textblock::frame_cache dictionary."
+ } -help "Perform an action on the frame cache."
}
proc frame_cache {args} {
set argd [punk::args::get_by_id ::textblock::frame_cache $args]
- set action [dict get $argd opts -action]
-
- if {$action ni [list clear ""]} {
- error "frame_cache action '$action' not understood. Valid actions: clear"
- }
+ set action [dict get $argd values action]
variable frame_cache
+ switch -- $action {
+ clear {
+ set size [dict size $frame_cache]
+ set frame_cache [tcl::dict::create]
+ return "frame_cache cleared $size entries"
+ }
+ size {
+ return [dict size $frame_cache]
+ }
+ info {
+ return [dict info $frame_cache]
+ }
+ display {
+ #fall through
+ }
+ default {
+ #assert - unreachable - punk::args should have validated
+ error "frame_cache -action '$action' not understood. Valid actions: clear size info display"
+ }
+ }
if {[dict get $argd opts -pretty]} {
set out [pdict -chan none frame_cache */*]
} else {
@@ -7544,10 +7616,6 @@ tcl::namespace::eval textblock {
append out \n ;# frames used to build tables often have joins - keep a line in between for clarity
}
}
- if {$action eq "clear"} {
- set frame_cache [tcl::dict::create]
- append out \nCLEARED
- }
return $out
}
@@ -7608,9 +7676,11 @@ tcl::namespace::eval textblock {
May contain ANSI - no trailing reset required.
${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing
e.g 2: frame -title [a+ red underline]MyThing${[textblock::RST]}"
+ -titlealign -default "centre" -choices {left centre right}
-subtitle -default "" -type string -regexprefail {\n}\
-help "Frame subtitle placed on bottombar - no newlines
May contain Ansi - no trailing reset required."
+ -subtitlealign -default "centre" -choices {left centre right}
-width -default "" -type int\
-help "Width of resulting frame including borders.
If omitted or empty-string, the width will be determined automatically based on content."
@@ -7667,7 +7737,9 @@ tcl::namespace::eval textblock {
-boxmap {}\
-joins [list]\
-title ""\
+ -titlealign "centre"\
-subtitle ""\
+ -subtitlealign "centre"\
-width ""\
-height ""\
-ansiborder ""\
@@ -7710,7 +7782,7 @@ tcl::namespace::eval textblock {
set k2 [tcl::prefix::match -error "" $optnames $k]
switch -- $k2 {
-etabs - -type - -boxlimits - -boxmap - -joins
- - -title - -subtitle - -width - -height
+ - -title - -titlealign - -subtitle - -subtitlealign - -width - -height
- -ansiborder - -ansibase
- -blockalign - -textalign - -ellipsis
- -crm_mode
@@ -7879,6 +7951,10 @@ tcl::namespace::eval textblock {
package require sha1
set hash [sha1::sha1 [encoding convertto utf-8 $hashables]]
}
+ sha256 {
+ package require sha256
+ set hash [sha2::sha256 [encoding convertto utf-8 $hashables]]
+ }
md5 {
package require md5
if {[package vsatisfies [package present md5] 2- ] } {
@@ -7887,7 +7963,7 @@ tcl::namespace::eval textblock {
set hash [md5::md5 [encoding convertto utf-8 $hashables]]
}
}
- none {
+ default {
set hash $hashables
}
}
@@ -8246,12 +8322,24 @@ tcl::namespace::eval textblock {
}
if {$opt_title ne ""} {
- set topbar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $tbar $opt_title] ;#overtype supports gx0 on/off
+ set titlealign [dict get $opts -titlealign]
+ set titlealignfull [tcl::prefix::match -error "" {left centre right} $titlealign]
+ if {$titlealignfull ni {left centre right}} {
+ error "textblock::frame -titlealign must be one of {left centre right} or a unique prefix thereof. Received $titlealign"
+ }
+ #set topbar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $tbar $opt_title] ;#overtype supports gx0 on/off
+ set topbar [overtype::block -blockalign $titlealignfull -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 $tbar $opt_title] ;#overtype supports gx0 on/off
} else {
set topbar $tbar
}
if {$opt_subtitle ne ""} {
- set bottombar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $bbar $opt_subtitle] ;#overtype supports gx0 on/off
+ set titlealign [dict get $opts -subtitlealign]
+ set titlealignfull [tcl::prefix::match -error "" {left centre right} $titlealign]
+ if {$titlealignfull ni {left centre right}} {
+ error "textblock::frame -subtitlealign must be one of {left centre right} or a unique prefix thereof. Received $titlealign"
+ }
+ #set bottombar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $bbar $opt_subtitle] ;#overtype supports gx0 on/off
+ set bottombar [overtype::block -blockalign $titlealignfull -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 $bbar $opt_subtitle] ;#overtype supports gx0 on/off
} else {
set bottombar $bbar
}
diff --git a/src/bootsupport/modules/zipper-0.12.tm b/src/bootsupport/modules/zipper-0.12.tm
index 6bf5e87eacb2aef2c5a678ce61f5af937be974d7..080e7da9391e33c62e5e9c49bd5c3006ae2e5f48 100644
GIT binary patch
delta 1668
zcmV-~27CGTO!rK%*BJ@4nmt-fc8oQsli(Rd6}x2jc563vsf%+}In23)G{CHd#A=f{
z8XE%t^pjQ^+W~u%G8;kxRFicZivh2*0UQhg0g;mq9i)HMZ+5AGE+0Evzy?Vinh{l;
zG4hSkQ{c?4YN7T<R#)=qFUKFQUZb{fb_U`xYQR0G$vKxf!{Nl?Zc`&Ttbm^Vv6@lA
z-;adYi^m1?Chrn*w*sK<S&=`bZrwWf3v2*P6fi)l$LGXwI1kYbN%mCn6gkSvm0UM-
zAZtC@QYU{BV`GB|n`?Abw}my*E5P~gJ92jqULNMZ8#sp{xED;ZDg85+UOJ*v*kr+q
z<pdDJ9&=<?!#R=@_aoBTsi9Cojafxg+qxLTz|T0M=u@P}6r{nEeu<g3{G^FI4Jvlo
zl8THHl?cF>FX6enJEW8hg@;45&oTmNSAV>9M3;Y`r`UpFE`i<Oe81mUgjZv6sdtCH
zqRi&E<F&H=lkLA2iO~`y2oGC<eR?QC^3b*rGc+9NKiVl`HVt9PAX-XNm$%lGwyZ*;
zvPYnBxrlUN3j!KB(XhBd3NKh7{F%n<H~*y53Y${|?;_Rca{z~5TCT1~68KA_8o+@z
zSc-qu_>C*U+%55KlVgQpNtZeu{M-A#<}0F`8zym+DlT{{b>ld?yzC0Fl&ukUJXe@2
zDfyTy@nia-qF+`V)bpAXFq#mYV-z2m?#UjWP-n~C?|#1SUH1vP>fUwx-QLA`(5)uY
z1$R4n!EX&+Id(PA?*~r}F0HjO7h2Q1pJ{*7qdxV!$QAstrR$1XaCwsIZ1{MU-0X3r
zdDTRLKa!w!2yB?NQ111gQB6N1NnWjT{dlR7-Pv$ErgC{5?i(iYDfe#h#*CyXtk>4$
zMw%-$d^e01hl%-udbKcq;O$+t8>`<`m-+QI>dddYM!myMxvO8B4)>%aC?oYzv}=Da
zj%)5;*t359%a4|-xO>mI-StM9Ak_;F)BQv`d{OnT_QqcIt!>uW8Nu}j7lT2;b;d&h
zdu7nB4SsE$SYv5BMC0w&hpX1vemGZE@O7F=#!<;hObk=d7s~so{QxtY;_=_^vx2ma
zCul}A@;}n*gio|cVq!z*>kke9Y`=d^!YeC3u3r))v>YJ&5%MfrnGF394w`xLZKG#;
z{P(w4yCj>I?a-A7_mZCD`vv|E_PNP!WHo}q1e!iv(EtuwHc}(1(Q<)h&Eqwx?g6{s
zW%u<%@?!KqN3wbH{|sfX5M%QtA#Jx+0{inyS-I-rFSg1{75dSpSX7oL*KB`y6qbwb
z6D};&7C*<o1P3!7+QG}X;8*K(>05H3Yby7mP_8KU3A}5cPQP5A-BF#j=w|0p-fitW
z@bJLU9(Ojv>EHo}9ZuG@JXybe+^SU+3$%9bv4^~aN1g*Go^O2MsBZ}NJo~dVMZWG&
z8tjTZ->_JIO=NvRyYUVD_FI4YY}GmQF*a?Q$CVoyklvsNu8Vh6cULyUFv=}z?Naj2
z#}#+^E4Z!2b64@w`s`>I2kiadP>6Hc&e*H$=<s=_l%v`m<BXA#tjT-l9k!{<gqF3?
zt`RFYju0EET4}W|$$$Tk*Kdd;&*!$9bKc<ksm*y$yMtOYeZVXF)+>LkPYmekR{YHq
zeY;PV+S@_et!TzgWvs@W?V(;dVoH0U?zBOJu(+LOsE8vu#k(8p4>Bif#R>5vnK-wY
z!f|;|W5t8%bQv2vkjyiA<S*l3#`91+uATchde~O2iNH^%tFG|RQ^Z`(<o5TO&O;hX
zlb-n+4qz9{nb!_Z``v&31#B%xYd2S)s#u}m+0hNR`<af<?W8_G?dQJ}rRujOPC|CO
z^FGV>#f!>}beJqyy7XQK`fI0VNx>S;l^uPZTMt{$811GE3tlqfLCJ2Ig}f16$(>zO
z4ciLo)Q_jit>_WFyBS~;EHm6o4yREv=Gi6>Ln2nX)!nZNzIuNlJsgcjJFU5xLl$Wx
zf4oU!qG0_=W|W)%T%SL-!^!GovWj~WI(>msW5L&qg!3ymP%%yfnj!ygAwy{=vK_AN
zgMfNzRBgH~(NT<Xa&2(sKA?=e5{Xf~x*B$8BF?KU*I|x5PrlBTY^=HF*aDCn=W?S~
zxeDn>1+<Limyr)uvBJ`^GZPi5tk{c~{R6YKBN+k-w3<CyOm>VlsFT(uWdi64lh7k0
OlVBzg2K5U70001h9a5(N
delta 1679
zcmV;A25|ZJO!iE$*BJ@@V`N#zOykO@li(Rd729O@c563vsf%+}In23)G{CHd#A%Z`
z8XE%r{F7E1+W`lYG8;kxT$6Phive%50UQhg0g00i9i)F=zO+jPbotoX0yaqE(2S_!
zjFE4Qo&slXRSUH@vbvH-e>whe^%}K>vojEnQ3LKdP0qQ@84f27cbgi)VFmQ;kJXF{
z{(dCHUOX<CH+h$kyA=R+&x-shb?er-Utj}ZqJRNXJw7Lf!+D5iNV2Djr^r!WuH?Fz
z16k|ImO6it7#kZz*j%Hdx-G1cUIET`-;uj}@bWPK-M~2v!M$LLP3fPp^wJTX!X^t=
zEGK{%_Lw8H8qSfNxF3<uP7Q?$YRoE{+SbJw27bm7MV}%)rXUTT^h?aN<tI(#X;87t
zmQ-Yvs6+t5GrNr)Qc8xx!y(#d83DAbKi)c`%g=vPY{4*>!0vCp-|s8JtFgG$yTe{l
zX7k(eTG{@|_Fs#{XbBR8hpoUqJ(M7MXj_OG8V>Xy?G!PahOlH1EhVYTTWd;NRv}T@
zBT%?pL^`kq0gaq!Sll3m7c3C|Oyl*Nf6!@#%_)L+k!tigfWt2>SJxv6{H0M1;6NKJ
z#cF^2#+6|1miV^GvBI#VOPvn>?fqZ#717NNlekG07rd3aaU5M<b_H0<)`&WuE6kOY
ze9V>jG5uK4FDnk}dCdtJO$g30ijPe9WDifMv*qr0zg+jO`vhHe@4EeN?_xaYRuk!h
zyPdq?w}!49yPD_sgQo_U*4mg0t?At_wCR6QpZZ<o3jWyAbww?>JV|vne7s6-_BhhK
zYNEg&Nl-fkHcVP5_xjJMrk{}{uU5H!ywu3<Y`7g$xx5bd4U_nkdpCGvM$#14Yin{N
z%@rEH8%B%6#C$=$S{Og@_O9BE)o-fH{Q4So=2u;#-eITQ)vry5dr}gVk@_gwwHJTK
zHTN&<S-<}2M@v=Qy=UC+dZSE`>IH}Cej**dsCrj>W3T$wHf!vR;QE7$!Jyze<Dr1P
zGHBNZzcx;+v9ukc@pkLORqJd&oU1DMI?W{GsN^IjhAHR^<^9xtgqcn8`1|{;Ag$vG
znh}lskF+}B6D^XM*wFd<g98BDZ<BxU%F2)H*8~YI2grVeJd0K)LqCLrW}bZ8=$Rh>
z?d{br$);sHbS1*Qr04j4fxm-&Zn7I$ji4}rrVm#%fP<Ee)QD=dTwq!AculH%!0vb1
zef^NU82!(YY@Yl-L)k0D*nCMy+ijJ={=8CFu6p>Zt@2WZezGYRmF3Ab8y<g!<)Zt9
z3k$Wy&+#w8!HkD?@G>s=)jD1JmK^As%DpI*D~f#r@7kx+FV|;xRA()^*?E+ATl)??
zJTSD!osDohc)($YlXWdm)^8uTY8Ax-t(|-9A@AUk=fH{Q8y`688-hL0{_ISVulth*
zyCTmwES6srSzpj@d;`DzmOg)5b<TW@O`GO%<wgdiH|T-u;vLo9mCZ1Wa*JBKl)UqC
z#a;diZfo(}RlKx5JKDtod;d2S;#{^f_9{C%e4Z)gsCLIVW27W&^4@ueZR#?iWi7O8
z#LA5$#73%CTCGd+Km7gm8{)|Gxvl1$H@JRkbKcYLpw>(u@QS|m3hRFp1A4j@fAd7&
z?vthVc93=}nsHMZt1)MLs8^1d(jKTgZO|YrZl@V4;z&;M?#B9q%*k4DLi|W3&Ml^J
zT;9`I@nAY##>NgL^GqK3%Q%?vJk*YB=RS@ewpD8)@YCt4EBx~mF_$yB{e7nMkcQHv
zXTF95*u`?@wS&`sw|{>DTg%bf&DEzWRw#IObi?g_rsH!vsn1XQ`R_!j`p*(4A-mmq
zpXK}FMP)`hOcpF%dM^Y0wNtaCV2$R=j=s*VhplIfc2kB0FB$QmWH-!0-iWT`&aSD3
zZH08|$5Z82^a$SF46q578SW*A(<mA9Y?Fr}5i8y5?zaSAy^wz%jz*)M)?CaXi?oqH
z-lQ>6u>K@7%FVy8&mY_2WOXuG#XSj~zCfw5;A=+0`IQ@}7$*YFkbk$3p|lg(4%hZU
zK)p1oHr<x!D8@LsHn?&hP)1&f#3)`}4ZAZD=T(;LFvp%JU*}3T)?9OJ0mzMWxlyZJ
zg><9>TE_Cr$f^!lVd>bJiHcNK>_yD}0kgFu83GCYV`N#zOykO@lh-9>0_O>n(IX=k
ZP)h{{000000ssO4p8x;=^a}t0004mSVxIs2
diff --git a/src/modules/#modpod-zipper-999999.0a1.0/zipper-999999.0a1.0.tm b/src/modules/#modpod-zipper-999999.0a1.0/zipper-999999.0a1.0.tm
index d15942ae..5d5dbe3d 100644
--- a/src/modules/#modpod-zipper-999999.0a1.0/zipper-999999.0a1.0.tm
+++ b/src/modules/#modpod-zipper-999999.0a1.0/zipper-999999.0a1.0.tm
@@ -49,7 +49,7 @@ namespace eval zipper {
}
proc addentry {name contents {unixmtime ""} {force 0}} {
- if {$unixmtime == ""} { set unixmtime [clock seconds] }
+ if {$unixmtime eq ""} { set unixmtime [clock seconds] }
#lassign [dostime $date 1] date time ;#UTC would probably be more sensible - but convention seems to be localtime :/
lassign [dostime $unixmtime 0] date time
set flag 0
@@ -120,7 +120,7 @@ namespace eval zipper {
proc adddir {name {date ""} {force 0}} {
set name "${name}/"
- if {$date == ""} { set date [clock seconds] }
+ if {$date eq ""} { set date [clock seconds] }
lassign [dostime $date 0] date time
set flag 0
set type 0 ;# stored
diff --git a/src/modules/#tarjar-tarjar-2.3/#tarjar-loadscript-tarjar.tcl b/src/modules/#tarjar-tarjar-2.3/#tarjar-loadscript-tarjar.tcl
index 8cf897d0..45bede7d 100644
--- a/src/modules/#tarjar-tarjar-2.3/#tarjar-loadscript-tarjar.tcl
+++ b/src/modules/#tarjar-tarjar-2.3/#tarjar-loadscript-tarjar.tcl
@@ -407,7 +407,7 @@ proc ::tarjar::_::readHeader {data} {
}
set mode [string trim $mode " \x00"]
- if {$magic == "ustar "} {
+ if {$magic eq "ustar "} {
# gnu tar
# not fully supported
foreach x {uname gname prefix} {
@@ -416,7 +416,7 @@ proc ::tarjar::_::readHeader {data} {
foreach x {devmajor devminor} {
set $x [format %d 0[string trim [set $x] " \x00"]]
}
- } elseif {$magic == "ustar\x00"} {
+ } elseif {$magic eq "ustar\x00"} {
# posix tar
foreach x {uname gname prefix} {
set $x [string trim [set $x] "\x00"]
@@ -427,7 +427,7 @@ proc ::tarjar::_::readHeader {data} {
} else {
# old style tar
foreach x {uname gname devmajor devminor prefix} { set $x {} }
- if {$type == ""} {
+ if {$type eq ""} {
if {[string match */ $name]} {
set type 5
} else {
@@ -1090,7 +1090,7 @@ proc ::tarjar::_::HandleLongLink {fh hv} {
upvar 1 $hv header thelongname thelongname
# @LongName Part I.
- if {$header(type) == "L"} {
+ if {$header(type) eq "L"} {
# Size == Length of name. Read it, and pad to full 512
# size. After that is a regular header for the actual
# file, where we have to insert the name. This is handled
diff --git a/src/modules/funcl-0.1.tm b/src/modules/funcl-0.1.tm
index ccdc9d99..1d2fe64a 100644
--- a/src/modules/funcl-0.1.tm
+++ b/src/modules/funcl-0.1.tm
@@ -64,16 +64,19 @@ namespace eval funcl {
set posn [lsearch $cmdlist _]
if {$posn <= 0} {
append body $cmdlist
- if {$i == [expr {[llength $args] -2}]} {
- #append body " \$data"
+ if {$i == ([llength $args]-2)} {
append body " $wrap"
}
+ #if {$i == [expr {[llength $args] -2}]} {
+ # #append body " \$data"
+ # append body " $wrap"
+ #}
if {$i > 0} {
set t {]}
}
} else {
append body [lrange $cmdlist 0 $posn-1]
- if {$i == [expr {[llength $args] -2}]} {
+ if {$i == ([llength $args] -2)} {
#append body " \$data"
append body " $wrap"
}
@@ -291,7 +294,7 @@ namespace eval funcl {
set posn [lsearch $cmdlist _]
if {$posn <= 0} {
append body $cmdlist
- if {$i == [expr {[llength $args] -1}]} {
+ if {$i == ([llength $args] -1)} {
append body " \$data"
}
if {$i > 0} {
@@ -299,7 +302,7 @@ namespace eval funcl {
}
} else {
append body [lrange $cmdlist 0 $posn-1]
- if {$i == [expr {[llength $args] -1}]} {
+ if {$i == ([llength $args] -1)} {
append body " \$data"
}
set t [lrange $cmdlist $posn+1 end]
diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm
index 08359461..738d89c5 100644
--- a/src/modules/punk-0.1.tm
+++ b/src/modules/punk-0.1.tm
@@ -49,6 +49,17 @@ namespace eval punk {
}
set has_commandstack [expr {![catch {package require commandstack}]}]
+ if {$has_commandstack} {
+ if {[catch {
+ package require punk::packagepreference
+ } errM]} {
+ catch {puts stderr "Failed to load punk::packagepreference"}
+ }
+ catch punk::packagepreference::install
+ } else {
+ #
+ }
+
if {![interp issafe] && $has_commandstack && $::tcl_platform(platform) eq "windows"} {
#still a caching version of auto_execok - but with proper(fixed) search order
@@ -353,18 +364,12 @@ punk::aliascore::init
package require punk::repl::codethread
package require punk::config
#package require textblock
-package require punk::console
+package require punk::console ;#requires Thread
package require punk::ns
package require punk::winpath ;# for windows paths - but has functions that can be called on unix systems
package require punk::repo
package require punk::du
package require punk::mix::base
-if {[catch {
- package require punk::packagepreference
-} errM]} {
- puts stderr "Failed to load punk::packagepreference"
-}
-punk::packagepreference::install
namespace eval punk {
# -- --- ---
diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm
index 117f28fe..7ec78339 100644
--- a/src/modules/punk/args-999999.0a1.0.tm
+++ b/src/modules/punk/args-999999.0a1.0.tm
@@ -332,9 +332,11 @@ tcl::namespace::eval punk::args {
(used for trailing args that come after switches/opts)
%B%@argdisplay%N% ?opt val...?
options -header <str> (text for header row of table)
- -body <str> (text to replace entirety of autogenerated docs)
+ -body <str> (text to replace autogenerated arg info)
%B%@doc%N% ?opt val...?
options -name <str> -url <str>
+ %B%@seealso%N% ?opt val...?
+ options -name <str> -url <str> (for footer - unimplemented)
Some other options normally present on custom arguments are available
to use with the @leaders @opts @values directives to set defaults
@@ -842,7 +844,7 @@ tcl::namespace::eval punk::args {
#id An id will be allocated if no id line present or the -id value is "auto"
if {$DEF_definition_id ne ""} {
#disallow duplicate @id line
- error "punk::args::define - @id already set. Existing value $DEF_definition_id"
+ error "punk::args::define - @id already set. Existing value $DEF_definition_id\n[join $args \n]"
}
if {[dict exists $at_specs -id]} {
set DEF_definition_id [dict get $at_specs -id]
@@ -966,7 +968,7 @@ tcl::namespace::eval punk::args {
-anyopts {
set opt_any $v
}
- -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted {
+ -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted {
#review - only apply to certain types?
tcl::dict::set tmp_optspec_defaults $k $v
}
@@ -1012,7 +1014,7 @@ tcl::namespace::eval punk::args {
tcl::dict::set tmp_optspec_defaults $k $v
}
default {
- set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\
+ set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\
-nominsize -nomaxsize -norange -nochoices -nochoicelabels\
-type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\
-regexprepass -regexprefail -regexprefailmsg -validationtransform\
@@ -1050,7 +1052,7 @@ tcl::namespace::eval punk::args {
}
dict set F $fid LEADER_MAX $v
}
- -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase {
+ -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase {
#review - only apply to certain types?
tcl::dict::set tmp_leaderspec_defaults $k $v
}
@@ -1097,8 +1099,9 @@ tcl::namespace::eval punk::args {
}
default {
set known { -min -minvalues -max -maxvalues\
- -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\
- -nominsize -nomaxsize -norange -nochoices -nochoicelabels\
+ -minsize -maxsize -range\
+ -choices -choicegroups -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\
+ -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\
-type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\
-regexprepass -regexprefail -regexprefailmsg -validationtransform\
}
@@ -1135,7 +1138,7 @@ tcl::namespace::eval punk::args {
}
set val_max $v
}
- -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase {
+ -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase {
#review - only apply to certain types?
tcl::dict::set tmp_valspec_defaults $k $v
}
@@ -1182,7 +1185,9 @@ tcl::namespace::eval punk::args {
}
default {
set known { -min -minvalues -max -maxvalues\
- -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\
+ -minsize -maxsize -range\
+ -choices -choicegroups -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\
+ -nocase\
-nominsize -nomaxsize -norange -nochoices -nochoicelabels\
-type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\
-regexprepass -regexprefail -regexprefailmsg -validationtransform\
@@ -1195,6 +1200,10 @@ tcl::namespace::eval punk::args {
}
}
+ seealso {
+ #todo!
+ #like @doc, except displays in footer, multiple - sub-table?
+ }
default {
error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @argdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id"
}
@@ -1321,7 +1330,9 @@ tcl::namespace::eval punk::args {
}
}
}
- -default - -solo - -range - -choices - -choicegroups - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -minsize - -maxsize - -nocase - -optional - -multiple -
+ -default - -solo - -range -
+ -choices - -choicegroups - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -choiceinfo -
+ -minsize - -maxsize - -nocase - -optional - -multiple -
-validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE -
-regexprepass - -regexprefail - -regexprefailmsg
{
@@ -1528,80 +1539,181 @@ tcl::namespace::eval punk::args {
return $argdata_dict
}
- lappend PUNKARGS [list -dynamic 0 {
- @id -id ::punk::args::get_spec
- @cmd -name punk::args::get_definition -help\
- ""
- id -type string -help\
- "identifer for punk::args defintion
- This will usually be a fully-qualifed
- path for a command name"
- patternlist -type list -optional 1 -default * -help\
- "glob-style patterns for retrieving value or switch
- definitions. If ommitted or passed an empty string,
- the raw unresolved definition will be returned as
- a list, including possible leading flags such as
- -dynamic 0|1.
- If specified as * - the entire definition including
- directive lines will be returned in line form.
- (directives are lines beginning with
- @ e.g @id, @cmd etc)
- "
- override_dict -type dict -optional 1 -default "" -help\
- "unimplemented.
- Will allow overriding or adding flags to a returned
- definition line.
- "
- }]
- #rename get_definition ???
- proc get_spec {id args} {
- lassign $args patternlist override_dict
- if {[llength $args] > 2} {
- punk::args::get_by_id ::punk::args::get_spec [list $id {*}$args]
- return
+ #return raw definition list as created with 'define'
+ proc rawdef {id} {
+ variable argdefcache_by_id
+ set realid [real_id $id]
+ #return the raw definition - possibly with unresolved dynamic parts
+ if {![dict exists $argdefcache_by_id $realid]} {
+ return ""
}
- if {[llength $override_dict] % 2 != 0} {
- #malformed dict
- punk::args::get_by_id ::punk::args::get_spec [list $id {*}$args]
+ return [tcl::dict::get $argdefcache_by_id $realid]
+ }
+
+
+ namespace eval argdoc {
+ variable resolved_def_TYPE_CHOICES {* @id @cmd @leaders @opts @values @doc}
+
+ lappend PUNKARGS [list -dynamic 0 [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES] {
+ @id -id ::punk::args::resolved_def
+ @cmd -name punk::args::resolved_def -help\
+ ""
+ @leaders -min 0 -max 0
+ @opts
+ -form -default 0 -help\
+ "UNIMPLEMENTED
+ Ordinal index or name of command form"
+ -type -default * -choices {%TYPECHOICES%} -choiceprefix 0 -multiple 1
+ -override -type dict -optional 1 -default "" -help\
+ "dict of dicts. Key in outer dict is the name of a
+ directive or an argument. Inner dict is a map of
+ overrides/additions (-<flag> <newval>...) for that line.
+ (unimplemented).
+ "
+ @values -min 1 -max -1
+ id -type string -help\
+ "identifer for a punk::args definition
+ This will usually be a fully-qualifed
+ path for a command name"
+ pattern -type string -optional 1 -default * -multiple 1 -help\
+ "glob-style patterns for retrieving value or switch
+ definitions.
+
+ If -type is * and pattern is * the entire definition including
+ directive lines will be returned in line form.
+ (directives are lines beginning with
+ @ e.g @id, @cmd etc)
+
+ if -type is @leaders,@opts or @values matches from that type
+ will be returned.
+
+ if -type is another directive such as @id, @doc etc the
+ patterns are ignored.
+
+ "
+ }]]
+ }
+
+
+ proc resolved_def {args} {
+ set opts [dict create\
+ -type {}\
+ -form 0\
+ -override {}\
+ ]
+ if {[llength $args] < 1} {
+ #must have at least id
+ punk::args::get_by_id ::punk::args::resolved_def $args
return
}
+ set patterns [list]
+
+ #a definition id must not begin with "-"
+ for {set i 0} {$i < [llength $args]} {incr i} {
+ set a [lindex $args $i]
+ if {$a eq "-type"} {
+ incr i
+ dict lappend opts -type [lindex $args $i]
+ } elseif {[string match -* $a]} {
+ incr i
+ dict set opts $a [lindex $args $i]
+ } else {
+ set id [lindex $args $i]
+ set patterns [lrange $args $i+1 end]
+ break
+ }
+ if {$i == [llength $args]-1} {
+ punk::args::get_by_id ::punk::args::resolved_def $args
+ return
+ }
+ }
+ if {![llength $patterns]} {
+ set patterns [list *]
+ }
+ dict for {k v} $opts {
+ switch -- $k {
+ -form - -type - -override {}
+ default {
+ punk::args::get_by_id ::punk::args::resolved_def $args
+ return
+ }
+ }
+ }
+ set typelist [dict get $opts -type]
+ if {[llength $typelist] == 0} {
+ set typelist {*}
+ }
+ foreach type $typelist {
+ if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} {
+ punk::args::get_by_id ::punk::args::resolved_def $args
+ return
+ }
+ }
variable argdefcache_by_id
set realid [real_id $id]
+
if {$realid ne ""} {
- if {$patternlist eq ""} {
- #return the raw definition - possibly with unresolved dynamic parts
- return [tcl::dict::get $argdefcache_by_id $realid]
- } else {
- set deflist [tcl::dict::get $argdefcache_by_id $realid]
- set result ""
- set specdict [uplevel 1 [list ::punk::args::define {*}$deflist]]
- set arg_info [dict get $specdict ARG_INFO]
- foreach pat $patternlist {
- if {[string match $pat @id]} {
+ set deflist [tcl::dict::get $argdefcache_by_id $realid]
+ set result ""
+ set specdict [uplevel 1 [list ::punk::args::define {*}$deflist]]
+ set arg_info [dict get $specdict ARG_INFO]
+ set argtypes [dict create @opts option @leaders leader @values value]
+ foreach type $typelist {
+ switch -exact -- $type {
+ * {
+ append result \n "@id -id [dict get $specdict id]"
+ append result \n "@cmd [dict get $specdict cmd_info]"
+ append result \n "@doc [dict get $specdict doc_info]"
+ foreach tp {leader option value} {
+ foreach pat $patterns {
+ set matches [dict keys $arg_info $pat]
+ foreach m $matches {
+ set def [dict get $arg_info $m]
+ if {[dict get $def -ARGTYPE] eq $tp} {
+ set def [dict remove $def -ARGTYPE]
+ append result \n "$m $def"
+ }
+ }
+ }
+ }
+
+ }
+ @id {
#only a single id record can exist
append result \n "@id -id [dict get $specdict id]"
}
- if {[string match $pat @cmd]} {
+ @cmd {
#only a single @cmd record can exist
#merged if multiple in original def (?)
append result \n "@cmd [dict get $specdict cmd_info]"
}
- #todo @leaders, @opts, @values lines
- #can be multiple of each. We need to preserve order and interleave
- #with any matching arg_info results.
- #requires storing more info in the internal spec dictionary
- set matches [dict keys $arg_info $pat]
- foreach m $matches {
- set def [dict get $arg_info $m]
- set def [dict remove $def -ARGTYPE]
- append result \n "$m $def"
+ @doc {
+ #only a single @doc record can exist
+ append result \n "@doc [dict get $specdict doc_info]"
+ }
+ @leaders - @opts - @values {
+ #option,
+ foreach pat $patterns {
+ set matches [dict keys $arg_info $pat]
+ foreach m $matches {
+ set def [dict get $arg_info $m]
+ if {[dict get $def -ARGTYPE] eq [dict get $argtypes $type]} {
+ set def [dict remove $def -ARGTYPE]
+ append result \n "$m $def"
+ }
+ }
+ }
+ }
+ default {
}
}
- return $result
}
+
+ return $result
}
}
+
proc get_spec_values {id {patternlist *}} {
variable argdefcache_by_id
set realid [real_id $id]
@@ -1636,13 +1748,14 @@ tcl::namespace::eval punk::args {
#proc get_spec_opts ??
proc get_def {id} {
- if {[id_exists $id]} {
- return [define {*}[get_spec $id]]
- }
+ return [define {*}[rawdef $id]]
+ #if {[id_exists $id]} {
+ # return [define {*}[rawdef $id]]
+ #}
}
proc is_dynamic {id} {
- set spec [get_spec $id]
- return [expr {[lindex $spec 0] eq "-dynamic" && [lindex $spec 1]} ]
+ set deflist [rawdef $id]
+ return [expr {[lindex $deflist 0] eq "-dynamic" && [lindex $deflist 1]} ]
}
variable aliases
@@ -1661,6 +1774,8 @@ tcl::namespace::eval punk::args {
variable aliases
return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $argdefcache_by_id $match]]
}
+
+ #we don't automatically test for (autodef)$id - only direct ids and aliases
proc id_exists {id} {
variable argdefcache_by_id
variable aliases
@@ -1694,6 +1809,9 @@ tcl::namespace::eval punk::args {
return $id
} else {
if {![llength [update_definitions]]} {
+ if {[tcl::dict::exists $argdefcache_by_id (autodef)$id]} {
+ return (autodef)$id
+ }
return ""
} else {
if {[tcl::dict::exists $aliases $id]} {
@@ -1702,6 +1820,9 @@ tcl::namespace::eval punk::args {
if {[tcl::dict::exists $argdefcache_by_id $id]} {
return $id
}
+ if {[tcl::dict::exists $argdefcache_by_id (autodef)$id]} {
+ return (autodef)$id
+ }
return ""
}
}
@@ -1797,7 +1918,7 @@ tcl::namespace::eval punk::args {
@values -min 0 -max 0
}]
proc test_get_dict {args} {
- punk::args::get_dict {*}[punk::args::get_spec ::punk::args::test1] $args
+ punk::args::get_dict {*}[punk::args::rawdef ::punk::args::test1] $args
}
proc test_get_by_id {args} {
punk::args::get_by_id ::punk::args::test1 $args
@@ -2558,7 +2679,7 @@ tcl::namespace::eval punk::args {
mechanism and call this as necessary.
"
-return -default table -choices {string table tableobject}
- } {${[punk::args::get_spec ::punk::args::arg_error -scheme]}} {
+ } {${[punk::args::resolved_def -type @opts ::punk::args::arg_error -scheme]}} {
@values -min 0 -max 1
id -help\
@@ -2568,7 +2689,7 @@ tcl::namespace::eval punk::args {
proc usage {args} {
lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received
set id [dict get $values id]
- set definitionlist [get_spec $id]
+ set definitionlist [rawdef $id]
if {[llength $definitionlist] == 0} {
error "punk::args::usage - no such id: $id"
}
@@ -2589,7 +2710,7 @@ tcl::namespace::eval punk::args {
#deprecate?
proc get_by_id {id arglist} {
- set definitionlist [punk::args::get_spec $id]
+ set definitionlist [punk::args::rawdef $id]
if {[llength $definitionlist] == 0} {
error "punk::args::get_by_id - no such id: $id"
}
@@ -2633,6 +2754,25 @@ tcl::namespace::eval punk::args {
-errorstyle -type string -default enhanced -choices {enhanced standard minimal}
@values -min 3
sep -optional 0 -choices "--"
+
+
+ @form -form withid -synopsis "parse ?-form {int|<formname>...}? ?-errorstyle <choice>? -- withid $id"
+ withid -type literal -help\
+ "The literal value 'withid'"
+ id -type string -help\
+ "id of punk::args definition for a command"
+
+
+ @form -form withdef -synopsis "parse ?-form {int|<formname>...}? ?-errorstyle <choice>? -- withdef $def ?$def?"
+ withdef -type literal -help\
+ "The literal value 'withdef'"
+ def -type string -multiple 1 -optional 0 -help\
+ "Each remaining argument is a block of text
+ defining argument definitions.
+ As a special case, -dynamic <bool> may be
+ specified as the 1st 2 arguments. These are
+ not treated as an indicator to punk::args
+ about how to process the definition."
}]
proc parse {args} {
@@ -2669,7 +2809,8 @@ tcl::namespace::eval punk::args {
return "parse [llength $arglist] args withid $id, options:$opts"
}
withdef {
- if {[llength [lrange $args $split+3 end]] < 1} {
+ set deflist [lrange $args $split+3 end]
+ if {[llength $deflist] < 1} {
error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'"
}
return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts"
@@ -4173,7 +4314,7 @@ tcl::namespace::eval punk::args::lib {
# set PUNKARGS ""
#}
-lappend ::punk::args::register::NAMESPACES ::punk::args ::punk::args::lib
+lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
diff --git a/src/modules/punk/args/tclcore-999999.0a1.0.tm b/src/modules/punk/args/tclcore-999999.0a1.0.tm
index 5c27d6b4..723be151 100644
--- a/src/modules/punk/args/tclcore-999999.0a1.0.tm
+++ b/src/modules/punk/args/tclcore-999999.0a1.0.tm
@@ -171,40 +171,6 @@ tcl::namespace::eval punk::args::tclcore {
} "@doc -name Manpage: -url [manpage_tcl library]" ]
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---
- #categorise array subcommands based on currently known groupings.
- #we do this dynamically because Tcl ensembles (even some core ones) can have subcommands added at runtime.
- proc array_subcommands {} {
- package require punk::ns
- set subdict [punk::ns::ensemble_subcommands array]
- set expected_searchcmds {startsearch anymore nextelement donesearch}
- set searchcmds [list]
- foreach sc $expected_searchcmds {
- if {$sc in [dict keys $subdict]} {
- lappend searchcmds $sc
- }
- }
- set argdef ""
- append argdef "subcommand -choicegroups \{" \n
- append argdef " \"\" \{" \n
- append argdef " [dict keys [dict remove $subdict {*}$searchcmds]]" \n
- append argdef " \}" \n
- append argdef " \"search\" \{" \n
- append argdef " $searchcmds" \n
- append argdef " \}" \n
- append argdef " \} -choicecolumns 4 " \n
-
- return $argdef
- }
-
- lappend PUNKARGS [list -dynamic 1 {
- @id -id ::array
- @cmd -name "Builtin: array" -help\
- "Manipulate array variables"
- @values
- ${[punk::args::tclcore::array_subcommands]}
-
- } "@doc -name Manpage: -url [manpage_tcl array]" ]
-
#todo - make generic - take command and known_groups_dict
proc info_subcommands {} {
package require punk::ns
@@ -571,8 +537,113 @@ tcl::namespace::eval punk::args::tclcore {
"A list of PIDs"
} "@doc -name Manpage: -url [manpage_tcl namespace]" ]
+ ############################################################################################################################################################
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ # COMMANDS A-H
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ ############################################################################################################################################################
+
+ namespace eval argdoc {
+ #categorise array subcommands based on currently known groupings.
+ #we do this dynamically because Tcl ensembles (even some core ones) can have subcommands added at runtime.
+ proc array_subcommands {} {
+ package require punk::ns
+ set subdict [punk::ns::ensemble_subcommands array]
+ set expected_searchcmds {startsearch anymore nextelement donesearch}
+ set searchcmds [list]
+ foreach sc $expected_searchcmds {
+ if {$sc in [dict keys $subdict]} {
+ lappend searchcmds $sc
+ }
+ }
+ set argdef ""
+ append argdef "subcommand -choicegroups \{" \n
+ append argdef " \"\" \{" \n
+ append argdef " [dict keys [dict remove $subdict {*}$searchcmds]]" \n
+ append argdef " \}" \n
+ append argdef " \"search\" \{" \n
+ append argdef " $searchcmds" \n
+ append argdef " \}" \n
+ append argdef " \} -choicecolumns 4 " \n
+
+ return $argdef
+ }
+ }
+
+ lappend PUNKARGS [list -dynamic 1 {
+ @id -id ::array
+ @cmd -name "Builtin: array" -help\
+ "Manipulate array variables"
+ @values
+ ${[punk::args::tclcore::argdoc::array_subcommands]}
+
+ } "@doc -name Manpage: -url [manpage_tcl array]" ]
+
+
+
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ lappend PUNKARGS [list -dynamic 1 {
+ @id -id ::const
+ @cmd -name "Builtin: const" -help\
+ "Create and initialise a constant.
+
+ This command is normally used within a procedure body (or method body,
+ or lambda term) to create a constant within that procedure, or within a
+ namespace eval body to create a constant within that namespace. The
+ constant is an unmodifiable variable, called varName, that is initialised
+ with value. The result of const is always the empty string on success.
+ If a variable varname does not exist, it is create with its value set to
+ value and marked as a constant; this means that no other command (e.g set,
+ append, incr, unset) may modify or remove the variable; variables are
+ checked for whether they are constants before any traces are called. If a
+ variable varName already exists, it is an error unless that variable is
+ marked as a constant (in which case const is a no-op)
+
+ The varName may not be a qualified name or reference an element of an
+ array by any means. If the variable exists and is an array, that is an
+ error. Constants are normally only removed by their containing procedure
+ exiting or their namespace being deleted.
+ "
+ @values -min 1 -max 2
+ varName -help ""
+ value
+
+ } "@doc -name Manpage: -url [manpage_tcl const]" ]
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+
+ ############################################################################################################################################################
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ # COMMANDS I-L
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ ############################################################################################################################################################
+
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ punk::args::define {
+ @id -id ::lrange
+ @cmd -name "builtin: lrange" -help\
+ "return one or more adjacent elements from a list.
+ The new list returned consists of elements first through last, inclusive.
+ The index values first and last are interpreted the same as index values
+ for the command 'string index', supporting simple index arithmetic and
+ indices relative to the end of the list.
+ e.g lrange {a b c} 0 end-1
+ "
+ @values -min 3 -max 3
+ list -type list -help\
+ "tcl list as a value"
+ first -help\
+ "index expression for first element"
+ last -help\
+ "index expression for last element"
+ } "@doc -name Manpage: -url [manpage_tcl lrange]"
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
lappend PUNKARGS [list {
@id -id ::lappend
@cmd -name "builtin: lappend" -help\
@@ -583,7 +654,9 @@ tcl::namespace::eval punk::args::tclcore {
"variable name"
value -type any -optional 1 -multiple 1
} "@doc -name Manpage: -url [manpage_tcl lappend]"]
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id ::ledit
@cmd -name "builtin: ledit" -help\
@@ -596,7 +669,9 @@ tcl::namespace::eval punk::args::tclcore {
last -type indexexpression
value -type any -optional 1 -multiple 1
} "@doc -name Manpage: -url [manpage_tcl ledit]"
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id ::lpop
@cmd -name "builtin: lpop" -help\
@@ -616,7 +691,7 @@ tcl::namespace::eval punk::args::tclcore {
previous indexing operation, allowing the script to remove elements
in sublists, similar to lindex and lset."
} "@doc -name Manpage: -url [manpage_tcl lpop]"
-
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id ::lrange
@cmd -name "builtin: lrange" -help\
@@ -635,8 +710,66 @@ tcl::namespace::eval punk::args::tclcore {
last -help\
"index expression for last element"
} "@doc -name Manpage: -url [manpage_tcl lrange]"
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ ############################################################################################################################################################
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ # COMMANDS M-Z
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ ############################################################################################################################################################
+
+
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ punk::args::define {
+ @id -id ::set
+ @cmd -name "builtin: set" -help\
+ "Read and write variables.
+
+ Returns the value of variable varName. If value is specified,
+ then set the value of varName to value, creating a new variable
+ if one does not already exist, and return its value. If varName
+ contains an open parenthesis and ends with a close parenthesis,
+ then it refers to an array element: the characters before the
+ first open parenthesis are the name of the array, and the
+ characters between the parentheses are the index within the array.
+ Otherwise varName refers to a scalar variable.
+ If varName includes namespace qualifiers (in the array name if it
+ refers to an array element), or if varName is unqualified (does
+ not include the names of any containing namespaces) but no
+ procedure is active, varName refers to a namespace variable
+ resolved according to the rules described under NAME RESOLUTION
+ in the namespace manual page.
+ If a procedure is active and varName is unqualified, then varName
+ refers to a parameter or local variable of the procedure, unless
+ varName was declared to resolve differently through one of the
+ global, variable, or upvar commands.
+ "
+ @values -min 1 -max 2
+ varName -type string -help\
+ "name of scalar or array variable
+ scalar variable e.g myvar
+ array element e.g myarray(identifier.x)
+ namespaced scalar variable e.g ::ns1::myvar
+ namespaced array element e.g ::ns1::myarray(subelement)
+ Nested datastructures may be simulated with an array by using
+ some programmer chosen convention to seperate levels.
+ e.g set myarray(config,0) \"val1\"
+ set myarray(config,1) \"etc\"
+ set myarray(data,0) {a b c}
+ see the dict command for an alternative datastructure.
+ "
+ value -type any -optional 1
+ } "@doc -name Manpage: -url [manpage_tcl set]"
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+
+
+
+
+
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id ::tcl::string::cat
@@ -982,6 +1115,38 @@ tcl::namespace::eval punk::args::tclcore {
string -type string -optional 0
}] "@doc -name Manpage: -url [manpage_tcl string]"
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ punk::args::define {
+ @id -id ::variable
+ @cmd -name "builtin: variable" -help\
+ "Create and initialise a namespace variable.
+ "
+ @form -form "setvalues" -synopsis "variable ?name value...? ?name?"
+ @values -min 2 -max -1
+ #todo
+ #In this case - we don't want name_value to display - as this is only used for documenting a builtin
+ #For the case where an @argroups is used also for parsing - the help should display the synopsis form
+ #and also the name of the var in which it is placed.
+ # e.g
+ # ?{name value}...?
+ # (name_value)
+ #The second line giving an indication the resulting list of pairs can be accessed with something like:
+ # dict get $argd values name_value
+
+ #@arggroup -name name_value -min 1 -max 2 -optional 1 -multiple 1 -args {
+ # name
+ # value
+ # }
+
+ @form -form "declare" -synopsis "variable name"
+ @values -min 1 -max 1
+ name -optional 0
+
+ } "@doc -name Manpage: -url [manpage_tcl variable]"
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+
+
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id ::zlib
@cmd -name "builtin: ::zlib" -help\
@@ -1007,9 +1172,13 @@ tcl::namespace::eval punk::args::tclcore {
stream "zlib stream mode ?options?"
adler32 "zlib adler32 string ?initValue?"
crc32 "zlib crc32 string ?initValue?"
- }
+ }\
+ -choiceinfo {
+ adler32 {}
+ }
} "@doc -name Manpage: -url [manpage_tcl zlib]"
+
punk::args::define {
@id -id "::zlib adler32"
@cmd -name "builtin: ::zlib adler32" -help\
@@ -1020,6 +1189,7 @@ tcl::namespace::eval punk::args::tclcore {
string -type string
initValue -type string -optional 1
} "@doc -name Manpage: -url [manpage_tcl zlib]"
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
diff --git a/src/modules/punk/lib-999999.0a1.0.tm b/src/modules/punk/lib-999999.0a1.0.tm
index 74680b19..b2eb1c67 100644
--- a/src/modules/punk/lib-999999.0a1.0.tm
+++ b/src/modules/punk/lib-999999.0a1.0.tm
@@ -890,7 +890,7 @@ namespace eval punk::lib {
set cur [lmap a_l $list_l { lindex $a_l 0 }]
set list_l [lmap a_l $list_l { lrange $a_l 1 end }]
- if {[join $cur {}] == {}} {
+ if {[join $cur {}] eq {}} {
break
}
lappend zip_l $cur
diff --git a/src/modules/punk/mix/cli-999999.0a1.0.tm b/src/modules/punk/mix/cli-999999.0a1.0.tm
index fb2cb536..6d47f75d 100644
--- a/src/modules/punk/mix/cli-999999.0a1.0.tm
+++ b/src/modules/punk/mix/cli-999999.0a1.0.tm
@@ -687,27 +687,36 @@ namespace eval punk::mix::cli {
package require punk::zip
set zipfile $buildfolder/$basename-$module_build_version.zip ;#ordinary zip file (deflate)
- if 0 {
- #use -base $buildfolder so that -directory is included in the archive - the modpod stub relies on this - and extraction would be potentially messy otherwise
- punk::zip::mkzip -base $buildfolder -directory $buildfolder/#modpod-$basename-$module_build_version -- $zipfile *
- #punk::zip::mkzip stores permissions - (unix style) which confuses zipfs when reading - it misidentifies dirs as files
- }
#zipfs mkzip does exactly what we need anyway in this case
#unfortunately it's not available in all Tclsh versions we might be running..
if {[llength [info commands zipfs]]} {
+ #zipfs mkzip (2025) doesn't add entries for folders.
+ #(Therefore no timestamps)
+ #zip reading utils generally intuit their existence and display them - but often an editor can't add comments to them
set wd [pwd]
cd $buildfolder
puts "zipfs mkzip $zipfile #modpod-$basename-$module_build_version"
zipfs mkzip $zipfile #modpod-$basename-$module_build_version
cd $wd
- package require modpod
- modpod::lib::make_zip_modpod $zipfile $modulefile
} else {
+ #use -base $buildfolder so that -directory is included in the archive - the modpod stub relies on this - and extraction would be potentially messy otherwise
+ #put in an archive-level comment to aid in debugging
+ #punk
+ punk::zip::mkzip -base $buildfolder -directory $buildfolder/#modpod-$basename-$module_build_version -- $zipfile *
+ #punk::zip::mkzip stores permissions - (unix style) - which zipfs mkzip doesn't
+ #Directory ident in zipfs relies on folders ending with trailing slash - if missing, it misidentifies dirs as files.
+ #(ie it can't use permissions/attributes alone to determine directory vs file)
#TODO - review punk::zip::mkzip and/or external zip to provide a fallback?
- set had_error 1
- lappend notes "zipfs_unavailable"
- puts stderr "WARNING: zipfs unavailable can't build $modulefile"
+ #JMN25
+
+ #set had_error 1
+ #lappend notes "zipfs_unavailable"
+ #puts stderr "WARNING: zipfs unavailable can't build $modulefile"
+ }
+ if {!$had_error && [file exists $zipfiles]} {
+ package require modpod
+ modpod::lib::make_zip_modpod $zipfile $modulefile
}
diff --git a/src/modules/punk/mix/commandset/doc-999999.0a1.0.tm b/src/modules/punk/mix/commandset/doc-999999.0a1.0.tm
index e10f3347..54fc4208 100644
--- a/src/modules/punk/mix/commandset/doc-999999.0a1.0.tm
+++ b/src/modules/punk/mix/commandset/doc-999999.0a1.0.tm
@@ -22,7 +22,7 @@ package require punk::path ;# for treefilenames, relative
package require punk::repo
package require punk::docgen ;#inline doctools - generate doctools .man files at src/docgen prior to using kettle to producing .html .md etc
package require punk::mix::cli ;#punk::mix::cli::lib used for kettle_call
-#package require punk::mix::util ;#for path_relative
+#package require punkcheck ;#for path_relative
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
diff --git a/src/modules/punk/ns-999999.0a1.0.tm b/src/modules/punk/ns-999999.0a1.0.tm
index 3007afde..5cb49fbf 100644
--- a/src/modules/punk/ns-999999.0a1.0.tm
+++ b/src/modules/punk/ns-999999.0a1.0.tm
@@ -1995,7 +1995,7 @@ tcl::namespace::eval punk::ns {
-return -type string -default table -choices {string table tableobject}
- } {${[punk::args::get_spec ::punk::args::arg_error -scheme]}} {
+ } {${[punk::args::resolved_def -type @opts ::punk::args::arg_error -scheme]}} {
-- -type none -help\
"End of options marker
diff --git a/src/modules/punk/packagepreference-999999.0a1.0.tm b/src/modules/punk/packagepreference-999999.0a1.0.tm
index 976fa7cf..b3443895 100644
--- a/src/modules/punk/packagepreference-999999.0a1.0.tm
+++ b/src/modules/punk/packagepreference-999999.0a1.0.tm
@@ -119,6 +119,7 @@ tcl::namespace::eval punk::packagepreference {
#*** !doctools
#[call [fun install]]
#[para]Override ::package builtin (or the current implementation if it has already been renamed/overridden) to check for and prefer lowercase packages/modules
+ #[para](todo - check info loaded and restrict to existing version as determined from dll/so?)
#[para]The overriding package command will call whatever implementation was in place before install to do the actual work - once it has modified 'package require' names to lowercase.
#[para]This is intended to be in alignment with tip 590 "Recommend lowercase Package Names"
#[para] https://core.tcl-lang.org/tips/doc/trunk/tip/590.md
@@ -152,40 +153,83 @@ tcl::namespace::eval punk::packagepreference {
#despite preference for lowercase - we need to handle packages that insist on providing as uppercase
#(e.g we will still need to handle things like: package provide Tcl 8.6)
#Where the package is already provided uppercase we shouldn't waste time deferring to lowercase
+ set is_exact 0
if {[lindex $args 1] eq "-exact"} {
set pkg [lindex $args 2]
- set vwant [lindex $args 3]
- if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} {
- #although we could shortcircuit using vsatisfies to return the ver
- #we should instead pass through to COMMANDSTACKNEXT so as not to interfere with whatever it does.
- return [$COMMANDSTACKNEXT {*}$args]
-
- #if {$vwant eq "" || [$COMMANDSTACKNEXT vsatisfies $ver $vwant]} {
- # return $ver
- #} else {
- # #package already provided with a different version.. we will defer to underlying implementation to return the standard error
- # return [$COMMANDSTACKNEXT {*}$args]
- #}
- }
+ set vwant [lindex $args 3]-[lindex $args 3]
+ set is_exact 1
} else {
set pkg [lindex $args 1]
- set vwant [lindex $args 2]
- if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} {
- return [$COMMANDSTACKNEXT {*}$args]
- #if {$vwant eq "" || [$COMMANDSTACKNEXT vsatisfies $ver $vwant]} {
- # return $ver
- #}
+ set vwant [lrange $args 2 end] ;#rare - but version can be a list of options
+ if {[llength $vwant] == 1 && [string first - [lindex $vwant 0]] > 0} {
+ #only one version - and it has a dash
+ lassign [split [lindex $vwant 0] -] a b
+ if {$a eq $b} {
+ #string compare version nums (can contain dots and a|b)
+ set is_exact 1
+ }
+ }
+ }
+ if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} {
+ #although we could shortcircuit using vsatisfies to return the ver
+ #we should instead pass through to COMMANDSTACKNEXT so as not to interfere with whatever it does.
+ #e.g a package require logger further down the commandstack
+ return [$COMMANDSTACKNEXT {*}$args]
+ }
+
+ if {!$is_exact && [llength $vwant] <= 1 } {
+ #required version unspecified - or specified singularly
+ # ---------------------------------------------------------------
+ #An attempt to detect dll/so loaded and try to load same version
+ set pkgloadedinfo [lsearch -inline -index 1 [info loaded] $pkg]
+ if {![llength $pkgloadedinfo]} {
+ if {[regexp {[A-Z]} $pkg]} {
+ set pkgloadedinfo [lsearch -inline -index 1 [info loaded] [string tolower $pkg]]
+ if {![llength $pkgloadedinfo]} {
+ set pkgloadedinfo [lsearch -inline -index 1 [info loaded] [string totitle $pkg]]
+ }
+ }
+ }
+
+ if {[llength $pkgloadedinfo]} {
+ puts stderr "--> pkg not present but shared object seems to be loaded: $pkgloadedinfo"
+ lassign $pkgloadedinfo path name
+ set lcpath [string tolower $path]
+ set obj [file tail $lcpath]
+ if {[string match tcl9* $obj]} {
+ set obj [string range $obj 4 end]
+ } elseif {[string match lib* $obj]} {
+ set obj [string range $obj 3 end]
+ }
+ set pkginfo [file rootname $obj]
+ #e.g Thread2.8.8
+ if {[regexp {^([a-zA-Z\-]+)(.*)} $pkginfo _match lname lversion]} {
+ if {[string tolower $lname] eq [string tolower $pkg]} {
+ #name matches pkg
+ #hack for known dll version mismatch
+ if {[string tolower $pkg] eq "thread" && $lversion eq "30b3"} {
+ set lversion 3.0b3
+ }
+ if {[llength $vwant] == 1} {
+ #todo - still check vsatisfies - report a conflict? review
+ }
+ return [$COMMANDSTACKNEXT require $pkg $lversion-$lversion]
+ }
+ }
}
}
+ # ---------------------------------------------------------------
+ set pkgloadedinfo [lsearch -inline -index 1 [info loaded] $pkg]
+
if {[regexp {[A-Z]} $pkg]} {
#only apply catch & retry if there was a cap - otherwise we'll double try for errors unrelated to capitalisation
- if {[catch {$COMMANDSTACKNEXT {*}[string tolower $args]} v]} {
- return [$COMMANDSTACKNEXT {*}$args]
+ if {[catch {$COMMANDSTACKNEXT require [string tolower $pkg] {*}$vwant} v]} {
+ return [$COMMANDSTACKNEXT require $pkg {*}$vwant]
} else {
return $v
}
} else {
- return [$COMMANDSTACKNEXT {*}$args]
+ return [$COMMANDSTACKNEXT require $pkg {*}$vwant]
}
}
default {
diff --git a/src/modules/punk/repl-0.1.tm b/src/modules/punk/repl-0.1.tm
index 9859ed8e..63b82f02 100644
--- a/src/modules/punk/repl-0.1.tm
+++ b/src/modules/punk/repl-0.1.tm
@@ -2621,7 +2621,9 @@ namespace eval repl {
# }
#}
#puts stdout "===================="
-
+ package require punk::packagepreference
+ punk::packagepreference::install
+
package require punk::console
package require punk::repl::codethread
package require shellfilter
diff --git a/src/modules/punk/repl/codethread-999999.0a1.0.tm b/src/modules/punk/repl/codethread-999999.0a1.0.tm
index dd01a40d..257c4f55 100644
--- a/src/modules/punk/repl/codethread-999999.0a1.0.tm
+++ b/src/modules/punk/repl/codethread-999999.0a1.0.tm
@@ -137,6 +137,13 @@ tcl::namespace::eval punk::repl::codethread {
variable run_command_cache
+ #Use interp exists instead..
+ #if {[catch {interp children}]} {
+ # #8.6.10 doesn't have it.. when was it introduced?
+ #} else {
+
+ #}
+
proc is_running {} {
variable running
return $running
@@ -150,7 +157,7 @@ tcl::namespace::eval punk::repl::codethread {
#expecting to be called from a thread::send in parent repl - ie in the toplevel interp so that the sub-interp "code" is available
#if a thread::send is done from the commandline in a codethread - Tcl will
- if {"code" ni [interp children] || ![info exists replthread_cond]} {
+ if {![interp exists code] || ![info exists replthread_cond]} {
#in case someone tries calling from codethread directly - don't do anything or change any state
#(direct caller could create an interp named code at the level "" -> "code" -"code" and add a replthread_cond value to avoid this check - but it probably won't do anything useful)
#if called directly - the context will be within the first 'code' interp.
diff --git a/src/modules/punk/safe-999999.0a1.0.tm b/src/modules/punk/safe-999999.0a1.0.tm
index 14024071..367d6998 100644
--- a/src/modules/punk/safe-999999.0a1.0.tm
+++ b/src/modules/punk/safe-999999.0a1.0.tm
@@ -458,7 +458,7 @@ tcl::namespace::eval punk::safe {
# If we have exactly 2 arguments the semantic is a "configure get"
lassign $args child arg
- set spec_dict [punk::args::define [punk::args::get_spec punk::safe::interpIC]]
+ set spec_dict [punk::args::define [punk::args::rawdef punk::safe::interpIC]]
set opt_names [dict get $spec_dict opt_names]
CheckInterp $child
@@ -631,6 +631,17 @@ tcl::namespace::eval punk::safe {
SyncAccessPath $child
return $token
}
+
+ if {[catch {interp children}]} {
+ #8.6.10 doesn't have it.. when was it introduced?
+ proc interp_children {{i {}}} {
+ puts stderr "punk::safe 'interp children' subcommand not available"
+ }
+ } else {
+ proc interp_children {{i {}}} {
+ interp children {*}$i
+ }
+ }
# This procedure deletes a safe interpreter managed by Safe Tcl and cleans up
# associated state.
# - The command will also delete non-Safe-Base interpreters.
@@ -648,7 +659,7 @@ tcl::namespace::eval punk::safe {
# Base. To clean up properly, we call safe::interpDelete recursively on each
# Safe Base sub-interpreter, so each one is deleted cleanly and not by
# the automatic mechanism built into [interp delete].
- foreach sub [interp children $child] {
+ foreach sub [interp_children $child] {
if {[info exists ::punk::safe::system::[VarName [list $child $sub]]]} {
::punk::safe::interpDelete [list $child $sub]
}
@@ -762,7 +773,7 @@ tcl::namespace::eval punk::safe::system {
"::auto_path for the child"}
}
punk::args::define $OPTS
- set optlines [punk::args::get_spec punk::safe::OPTS -*]
+ set optlines [punk::args::resolved_def -type @opts punk::safe::OPTS -*]
set INTERPCREATE {
@id -id ::punk::safe::interpCreate
diff --git a/src/modules/punk/zip-999999.0a1.0.tm b/src/modules/punk/zip-999999.0a1.0.tm
index 30912446..9f7787fe 100644
--- a/src/modules/punk/zip-999999.0a1.0.tm
+++ b/src/modules/punk/zip-999999.0a1.0.tm
@@ -179,26 +179,55 @@ tcl::namespace::eval punk::zip {
# punk::zip::walk -exclude {CVS/* *~.#*} library
#}]
+ #todo: -relative 0|1 flag?
set argd [punk::args::get_dict {
@id -id ::punk::zip::walk
- @cmd -name punk::zip::walk
+ @cmd -name punk::zip::walk -help\
+ "Walk the directory structure starting at base/<-subpath>
+ and return a list of the files and folders encountered.
+ Resulting paths are relative to base unless -resultrelative
+ is supplied.
+ Folder names will end with a trailing slash.
+ "
+ -resultrelative -optional 1 -help\
+ "Resulting paths are relative to this value.
+ Defaults to the value of base. If empty string
+ is given to -resultrelative the paths returned
+ are effectively absolute paths."
-excludes -default "" -help "list of glob expressions to match against files and exclude"
- -subpath -default ""
+ -subpath -default "" -help\
+ "May contain glob chars for folder elements"
@values -min 1 -max -1
base
fileglobs -default {*} -multiple 1
} $args]
set base [dict get $argd values base]
- set fileglobs [dict get $argd values fileglobs]
+ set fileglobs [dict get $argd values fileglobs]
set subpath [dict get $argd opts -subpath]
set excludes [dict get $argd opts -excludes]
+ set received [dict get $argd received]
set imatch [list]
foreach fg $fileglobs {
lappend imatch [file join $subpath $fg]
}
+ if {![dict exists $received -resultrelative]} {
+ set relto $base
+ set prefix ""
+ } else {
+ set relto [file normalize [dict get $argd opts -resultrelative]]
+ if {$relto ne ""} {
+ if {![Path_a_atorbelow_b $base $relto]} {
+ error "punk::zip::walk base must be at or below -resultrelative value (backtracking not currently supported)"
+ }
+ set prefix [Path_strip_alreadynormalized_prefixdepth $base $relto]
+ } else {
+ set prefix $base
+ }
+ }
+
set result {}
#set imatch [file join $subpath $match]
set files [glob -nocomplain -tails -types f -directory $base -- {*}$imatch]
@@ -210,7 +239,7 @@ tcl::namespace::eval punk::zip {
break
}
}
- if {!$excluded} {lappend result $file}
+ if {!$excluded} {lappend result [file join $prefix $file]}
}
foreach dir [glob -nocomplain -tails -types d -directory $base -- [file join $subpath *]] {
set subdir_entries [walk -subpath $dir -excludes $excludes $base {*}$fileglobs]
@@ -218,7 +247,7 @@ tcl::namespace::eval punk::zip {
#NOTE: trailing slash required for entries to be recognised as 'file type' = "directory"
#This is true for 2024 Tcl9 mounted zipfs at least. zip utilities such as 7zip seem(icon correct) to recognize dirs with or without trailing slash
#Although there are attributes on some systems to specify if entry is a directory - it appears trailing slash should always be used for folder names.
- set result [list {*}$result "$dir/" {*}$subdir_entries]
+ set result [list {*}$result "[file join $prefix $dir]/" {*}$subdir_entries]
}
}
return $result
@@ -554,7 +583,9 @@ tcl::namespace::eval punk::zip {
-comment -default ""\
-help "An optional comment for the archive"
-directory -default ""\
- -help "The new zip archive will scan for contents within this folder or current directory if not provided."
+ -help "The new zip archive will scan for contents within this folder or current directory if not provided.
+ Note that this will
+ "
-base -default ""\
-help "The new zip archive will be rooted in this directory if provided
it must be a parent of -directory or the same path as -directory"
@@ -605,6 +636,7 @@ tcl::namespace::eval punk::zip {
set base $opts(-directory)
set relpath ""
}
+ #will pick up intermediary folders as paths (ending with trailing slash)
set paths [walk -exclude $opts(-exclude) -subpath $relpath -- $base {*}[dict get $argd values globs]]
set norm_filename [file normalize $filename]
@@ -654,6 +686,8 @@ tcl::namespace::eval punk::zip {
}
}
} else {
+ #NOTE that we don't add intermediate folders when creating an archive without using the -directory flag!
+ #ie - only the exact *files* matching the glob are stored.
set paths [list]
set dir [pwd]
if {$opts(-base) ne ""} {
@@ -712,7 +746,7 @@ tcl::namespace::eval punk::zip {
if {$opts(-offsettype) eq "archive"} {
set dataStartOffset [tell $zf] ;#the overall file offset of the start of archive-data //JMN 2024
} else {
- set dataStartOffset 0 ;#offsets relative to file - the zipfs mkzip way :/
+ set dataStartOffset 0 ;#offsets relative to file - the (old) zipfs mkzip way :/
}
set count 0
diff --git a/src/modules/shellthread-1.6.1.tm b/src/modules/shellthread-1.6.1.tm
index 2670058d..f0d3ad8a 100644
--- a/src/modules/shellthread-1.6.1.tm
+++ b/src/modules/shellthread-1.6.1.tm
@@ -521,6 +521,9 @@ namespace eval shellthread::manager {
set ::auto_path [dict get $::settingsinfo auto_path]
}
+ package require punk::packagepreference
+ punk::packagepreference::install
+
package require Thread
package require shellthread
if {![catch {::shellthread::worker::init %tidcli% %ts_start% $::settingsinfo} errmsg]} {
diff --git a/src/modules/textblock-999999.0a1.0.tm b/src/modules/textblock-999999.0a1.0.tm
index 7e8da071..2a4bbc60 100644
--- a/src/modules/textblock-999999.0a1.0.tm
+++ b/src/modules/textblock-999999.0a1.0.tm
@@ -96,42 +96,60 @@ tcl::namespace::eval textblock {
variable use_hash ;#framecache
set use_hash none ;#slightly faster but uglier layout for viewing frame_cache display
- #if {![catch {package require sha1}]} {
- # set use_hash sha1
- #} elseif {![catch {package require md5}]} {
- # set use_hash md5
- #} else {
- # set use_hash none
- #}
- proc use_hash {args} {
- set choices [list none]
- set unavailable [list]
- set pkgs [package names]
- if {"md5" in $pkgs} {
- lappend choices md5
- } else {
- lappend unavailable md5
+ namespace eval argdoc {
+ proc hash_algorithm_choices_and_help {} {
+ set choices [list none]
+ set unavailable [list]
+ set unloaded [dict create]
+ set algorithm_packages {md5 sha1 sha256}
+ foreach p $algorithm_packages {
+ if {[package provide $p] eq ""} {
+ dict set unloaded $p ""
+ }
+ }
+ if {[dict size $unloaded]} {
+ set allpkgs [package names] ;#only retrieve once
+ foreach p $algorithm_packages {
+ if {[dict exists $unloaded $p]} {
+ #not loaded - but check if available
+ if {$p in $allpkgs} {
+ lappend choices $p
+ } else {
+ lappend unavailable $p
+ }
+ } else {
+ lappend choices $p
+ }
+ }
+ } else {
+ lappend choices {*}$algorithm_packages
+ set unavailable ""
+ }
+
+ set choicemsg ""
+ if {[llength $unavailable]} {
+ set choicemsg " (unavailable packages: $unavailable)"
+ }
+ #return $choices
+ return " -choices \{$choices\} -help {algorithm choice $choicemsg} "
}
- if {"sha1" in $pkgs} {
- lappend choices sha1
- } else {
- lappend unavailable sha1
- }
- set choicemsg ""
- if {[llength $unavailable]} {
- set choicemsg " (unavailable packages: $unavailable)"
- }
- set argd [punk::args::get_dict [tstr -return string {
- @id -id ::textblock::use_hash
- @cmd -name "textblock::use_hash" -help\
- "Hashing algorithm to use for framecache lookup.
- 'none' may be slightly faster but less compact
- when viewing textblock::framecache"
- @values -min 0 -max 1
- hash_algorithm -choices {${$choices}} -optional 1 -help\
- "algorithm choice ${$choicemsg}"
- }] $args]
+ }
+
+ # hash_algorithm -optional 1 -choices {${[::textblock::argdoc::hash_algorithm_choices]}} -help\
+ # "algorithm choice"
+
+ punk::args::define -dynamic 1 {
+ @id -id ::textblock::use_hash
+ @cmd -name "textblock::use_hash" -help\
+ "Hashing algorithm to use for framecache lookup.
+ 'none' may be slightly faster but less compact
+ when viewing textblock::framecache"
+ @values -min 0 -max 1
+ hash_algorithm -optional 1 ${[::textblock::argdoc::hash_algorithm_choices_and_help]}
+ }
+ proc use_hash {args} {
+ set argd [punk::args::get_by_id ::textblock::use_hash $args]
variable use_hash
if {![dict exists $argd received hash_algorithm]} {
return $use_hash
@@ -4367,6 +4385,15 @@ tcl::namespace::eval textblock {
"
-return -default table -choices {table tableobject}
+ -table -default "" -type string\
+ -help "existing table object to use"
+ -action -default "append" -choices {append replace}\
+ -help "row insertion method if existing -table is supplied
+ if append is chosen the new values will always start at the first column"
+ -title -type string -help\
+ "Title to display overlayed on top edge of table.
+ Will not be visible if -show_edge is false"
+ -titlealign -type string -choices {left centre right}
-frametype -default "light" -type dict -choices {${$FRAMETYPES}} -choicerestricted 0\
-help "frame type or dict for custom frame"
-show_edge -default "" -type boolean\
@@ -4377,10 +4404,21 @@ tcl::namespace::eval textblock {
-show_hseps -default "" -type boolean\
-help "Show horizontal table separators
(default 0 if no existing -table supplied)"
- -table -default "" -type string\
- -help "existing table object to use"
-colheaders -default "" -type list\
- -help "list of lists. list of column header values. Outer list must match number of columns"
+ -help {list of lists. list of column header values. Outer list must match number of columns.
+ A table
+ e.g single header row: -colheaders {{column_a} {column_b} {column_c}}
+ e.g 2 header rows: -colheaders {{column_a "nextrow test"} {column_b} {column_c}}
+ Note that each element of the outer list is itself a list so:
+ -colheaders {"column a" "column b" "column c"}
+ Is likely not the right format if it was intended to have a single header row where the
+ column titles contain spaces.
+ The correct syntax for that would be:
+ -colheaders {{"column a"} {"column b"} {"column c"}}
+ For spanning header cells - use 'set t [list_as_table -return tableobject ...]'
+ and then something like:
+ $t configure_header 1 -colspans {3 0 0}; $t print
+ }
-header -default "" -type list -multiple 1\
-help "Each supplied -header argument is a header row.
The number of values for each must be <= number of columns"
@@ -4388,9 +4426,6 @@ tcl::namespace::eval textblock {
-help "Whether to show a header row.
Omit for unspecified/automatic,
in which case it will display only if -headers list was supplied."
- -action -default "append" -choices {append replace}\
- -help "row insertion method if existing -table is supplied
- if append is chosen the new values will always start at the first column"
-columns -default "" -type integer\
-help "Number of table columns
Will default to 2 if not using an existing -table object"
@@ -4404,6 +4439,7 @@ tcl::namespace::eval textblock {
set argd [punk::args::get_by_id ::textblock::list_as_table $args]
set opts [dict get $argd opts]
+ set received [dict get $argd received]
set datalist [dict get $argd values datalist]
set existing_table [dict get $opts -table]
@@ -4560,6 +4596,12 @@ tcl::namespace::eval textblock {
}
$t add_row $row
}
+ if {"-title" in $received} {
+ $t configure -title [dict get $opts -title]
+ }
+ if {"-titlealign" in $received} {
+ $t configure -titlealign [dict get $opts -titlealign]
+ }
#puts stdout $rowdata
if {[tcl::dict::get $opts -return] eq "table"} {
set result [$t print]
@@ -5895,7 +5937,16 @@ tcl::namespace::eval textblock {
append out [textblock::join -- $punks $cpunks] \n
set 2frames_a [textblock::join -- [textblock::frame -checkargs 0 $cpunks] [textblock::frame -checkargs 0 $punks]]
append out $2frames_a \n
- set 2frames_b [textblock::join -- [textblock::frame -checkargs 0 -ansiborder $cyanb -title "plainpunks" $punks] [textblock::frame -checkargs 0 -ansiborder $greenb -title "fancypunks" $cpunks]]
+ set 2frames_b [textblock::join --\
+ [textblock::frame -checkargs 0 -ansiborder $cyanb\
+ -title "plainpunks" $punks]\
+ [textblock::frame -checkargs 0 -ansiborder $greenb\
+ -title "fancy"\
+ -titlealign right\
+ -subtitle "punks"\
+ -subtitlealign left\
+ $cpunks]\
+ ]
append out [textblock::frame -checkargs 0 -title "punks" $2frames_b\n$RST$2frames_a] \n
set punkdeck [overtype::right [overtype::left [textblock::frame -checkargs 0 -ansiborder [a+ green bold] -type heavy -title ${redb}PATTERN$RST -subtitle ${redb}PUNK$RST $prightair_cyanb] "$blueb\n\n\P\nU\nN\nK$RST"] "$blueb\n\nD\nE\nC\nK"]
set spantable [[spantest] print]
@@ -7503,20 +7554,41 @@ tcl::namespace::eval textblock {
@id -id ::textblock::frame_cache
@cmd -name textblock::frame_cache -help\
"Display or clear the frame cache."
- -action -default {} -choices {clear} -help\
- "Clear the textblock::frame_cache dictionary"
-pretty -default 1 -help\
- "Use 'pdict textblock::frame_cache */*' for prettier output"
- @values -min 0 -max 0
+ "Uses 'pdict textblock::frame_cache */*' for prettier output
+ Either way this is set, output requires long lines and may
+ still wrap in an ugly manner. Try 'textblock::use_cache md5'
+ to shorten the argument display and reduce wrapping.
+ "
+ @values -min 0 -max 1
+ action -default {display} -choices {clear size info display} -choicelabels {
+ clear "Clear the textblock::frame_cache dictionary."
+ } -help "Perform an action on the frame cache."
}
proc frame_cache {args} {
set argd [punk::args::get_by_id ::textblock::frame_cache $args]
- set action [dict get $argd opts -action]
-
- if {$action ni [list clear ""]} {
- error "frame_cache action '$action' not understood. Valid actions: clear"
- }
+ set action [dict get $argd values action]
variable frame_cache
+ switch -- $action {
+ clear {
+ set size [dict size $frame_cache]
+ set frame_cache [tcl::dict::create]
+ return "frame_cache cleared $size entries"
+ }
+ size {
+ return [dict size $frame_cache]
+ }
+ info {
+ return [dict info $frame_cache]
+ }
+ display {
+ #fall through
+ }
+ default {
+ #assert - unreachable - punk::args should have validated
+ error "frame_cache -action '$action' not understood. Valid actions: clear size info display"
+ }
+ }
if {[dict get $argd opts -pretty]} {
set out [pdict -chan none frame_cache */*]
} else {
@@ -7544,10 +7616,6 @@ tcl::namespace::eval textblock {
append out \n ;# frames used to build tables often have joins - keep a line in between for clarity
}
}
- if {$action eq "clear"} {
- set frame_cache [tcl::dict::create]
- append out \nCLEARED
- }
return $out
}
@@ -7608,9 +7676,11 @@ tcl::namespace::eval textblock {
May contain ANSI - no trailing reset required.
${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing
e.g 2: frame -title [a+ red underline]MyThing${[textblock::RST]}"
+ -titlealign -default "centre" -choices {left centre right}
-subtitle -default "" -type string -regexprefail {\n}\
-help "Frame subtitle placed on bottombar - no newlines
May contain Ansi - no trailing reset required."
+ -subtitlealign -default "centre" -choices {left centre right}
-width -default "" -type int\
-help "Width of resulting frame including borders.
If omitted or empty-string, the width will be determined automatically based on content."
@@ -7667,7 +7737,9 @@ tcl::namespace::eval textblock {
-boxmap {}\
-joins [list]\
-title ""\
+ -titlealign "centre"\
-subtitle ""\
+ -subtitlealign "centre"\
-width ""\
-height ""\
-ansiborder ""\
@@ -7710,7 +7782,7 @@ tcl::namespace::eval textblock {
set k2 [tcl::prefix::match -error "" $optnames $k]
switch -- $k2 {
-etabs - -type - -boxlimits - -boxmap - -joins
- - -title - -subtitle - -width - -height
+ - -title - -titlealign - -subtitle - -subtitlealign - -width - -height
- -ansiborder - -ansibase
- -blockalign - -textalign - -ellipsis
- -crm_mode
@@ -7879,6 +7951,10 @@ tcl::namespace::eval textblock {
package require sha1
set hash [sha1::sha1 [encoding convertto utf-8 $hashables]]
}
+ sha256 {
+ package require sha256
+ set hash [sha2::sha256 [encoding convertto utf-8 $hashables]]
+ }
md5 {
package require md5
if {[package vsatisfies [package present md5] 2- ] } {
@@ -7887,7 +7963,7 @@ tcl::namespace::eval textblock {
set hash [md5::md5 [encoding convertto utf-8 $hashables]]
}
}
- none {
+ default {
set hash $hashables
}
}
@@ -8246,12 +8322,24 @@ tcl::namespace::eval textblock {
}
if {$opt_title ne ""} {
- set topbar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $tbar $opt_title] ;#overtype supports gx0 on/off
+ set titlealign [dict get $opts -titlealign]
+ set titlealignfull [tcl::prefix::match -error "" {left centre right} $titlealign]
+ if {$titlealignfull ni {left centre right}} {
+ error "textblock::frame -titlealign must be one of {left centre right} or a unique prefix thereof. Received $titlealign"
+ }
+ #set topbar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $tbar $opt_title] ;#overtype supports gx0 on/off
+ set topbar [overtype::block -blockalign $titlealignfull -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 $tbar $opt_title] ;#overtype supports gx0 on/off
} else {
set topbar $tbar
}
if {$opt_subtitle ne ""} {
- set bottombar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $bbar $opt_subtitle] ;#overtype supports gx0 on/off
+ set titlealign [dict get $opts -subtitlealign]
+ set titlealignfull [tcl::prefix::match -error "" {left centre right} $titlealign]
+ if {$titlealignfull ni {left centre right}} {
+ error "textblock::frame -subtitlealign must be one of {left centre right} or a unique prefix thereof. Received $titlealign"
+ }
+ #set bottombar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $bbar $opt_subtitle] ;#overtype supports gx0 on/off
+ set bottombar [overtype::block -blockalign $titlealignfull -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 $bbar $opt_subtitle] ;#overtype supports gx0 on/off
} else {
set bottombar $bbar
}
diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/funcl-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/funcl-0.1.tm
index ccdc9d99..1d2fe64a 100644
--- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/funcl-0.1.tm
+++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/funcl-0.1.tm
@@ -64,16 +64,19 @@ namespace eval funcl {
set posn [lsearch $cmdlist _]
if {$posn <= 0} {
append body $cmdlist
- if {$i == [expr {[llength $args] -2}]} {
- #append body " \$data"
+ if {$i == ([llength $args]-2)} {
append body " $wrap"
}
+ #if {$i == [expr {[llength $args] -2}]} {
+ # #append body " \$data"
+ # append body " $wrap"
+ #}
if {$i > 0} {
set t {]}
}
} else {
append body [lrange $cmdlist 0 $posn-1]
- if {$i == [expr {[llength $args] -2}]} {
+ if {$i == ([llength $args] -2)} {
#append body " \$data"
append body " $wrap"
}
@@ -291,7 +294,7 @@ namespace eval funcl {
set posn [lsearch $cmdlist _]
if {$posn <= 0} {
append body $cmdlist
- if {$i == [expr {[llength $args] -1}]} {
+ if {$i == ([llength $args] -1)} {
append body " \$data"
}
if {$i > 0} {
@@ -299,7 +302,7 @@ namespace eval funcl {
}
} else {
append body [lrange $cmdlist 0 $posn-1]
- if {$i == [expr {[llength $args] -1}]} {
+ if {$i == ([llength $args] -1)} {
append body " \$data"
}
set t [lrange $cmdlist $posn+1 end]
diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/modpod-0.1.2.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/modpod-0.1.2.tm
index 166bd423..aa27ebce 100644
--- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/modpod-0.1.2.tm
+++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/modpod-0.1.2.tm
@@ -135,9 +135,10 @@ namespace eval modpod {
proc connect {args} {
puts stderr "modpod::connect--->>$args"
set argd [punk::args::get_dict {
+ @id -id ::modpod::connect
-type -default ""
- *values -min 1 -max 1
- path -type string -minlen 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)"
+ @values -min 1 -max 1
+ path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)"
} $args]
catch {
punk::lib::showdict $argd ;#heavy dependencies
@@ -329,14 +330,16 @@ namespace eval modpod::lib {
#zipfile is a pure zip at this point - ie no script/exe header
proc make_zip_modpod {args} {
set argd [punk::args::get_dict {
- -offsettype -default "archive" -choices {archive file} -help "Whether zip offsets are relative to start of file or start of zip-data within the file.
- 'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip,
- but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip)
- info-zip's 'zip -A' can sometimes convert archive-relative to file-relative.
- -offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'"
- *values -min 2 -max 2
- zipfile -type path -minlen 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries"
- outfile -type path -minlen 1 -help "path to output file. Name should be of the form packagename-version.tm"
+ @id -id ::modpod::lib::make_zip_modpod
+ -offsettype -default "archive" -choices {archive file} -help\
+ "Whether zip offsets are relative to start of file or start of zip-data within the file.
+ 'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip,
+ but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip)
+ info-zip's 'zip -A' can sometimes convert archive-relative to file-relative.
+ -offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'"
+ @values -min 2 -max 2
+ zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries"
+ outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm"
} $args]
set zipfile [dict get $argd values zipfile]
set outfile [dict get $argd values outfile]
diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm
index 08359461..738d89c5 100644
--- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm
+++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm
@@ -49,6 +49,17 @@ namespace eval punk {
}
set has_commandstack [expr {![catch {package require commandstack}]}]
+ if {$has_commandstack} {
+ if {[catch {
+ package require punk::packagepreference
+ } errM]} {
+ catch {puts stderr "Failed to load punk::packagepreference"}
+ }
+ catch punk::packagepreference::install
+ } else {
+ #
+ }
+
if {![interp issafe] && $has_commandstack && $::tcl_platform(platform) eq "windows"} {
#still a caching version of auto_execok - but with proper(fixed) search order
@@ -353,18 +364,12 @@ punk::aliascore::init
package require punk::repl::codethread
package require punk::config
#package require textblock
-package require punk::console
+package require punk::console ;#requires Thread
package require punk::ns
package require punk::winpath ;# for windows paths - but has functions that can be called on unix systems
package require punk::repo
package require punk::du
package require punk::mix::base
-if {[catch {
- package require punk::packagepreference
-} errM]} {
- puts stderr "Failed to load punk::packagepreference"
-}
-punk::packagepreference::install
namespace eval punk {
# -- --- ---
diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm
index 78a18304..37f8b712 100644
--- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm
+++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm
@@ -332,9 +332,11 @@ tcl::namespace::eval punk::args {
(used for trailing args that come after switches/opts)
%B%@argdisplay%N% ?opt val...?
options -header <str> (text for header row of table)
- -body <str> (text to replace entirety of autogenerated docs)
+ -body <str> (text to replace autogenerated arg info)
%B%@doc%N% ?opt val...?
options -name <str> -url <str>
+ %B%@seealso%N% ?opt val...?
+ options -name <str> -url <str> (for footer - unimplemented)
Some other options normally present on custom arguments are available
to use with the @leaders @opts @values directives to set defaults
@@ -842,7 +844,7 @@ tcl::namespace::eval punk::args {
#id An id will be allocated if no id line present or the -id value is "auto"
if {$DEF_definition_id ne ""} {
#disallow duplicate @id line
- error "punk::args::define - @id already set. Existing value $DEF_definition_id"
+ error "punk::args::define - @id already set. Existing value $DEF_definition_id\n[join $args \n]"
}
if {[dict exists $at_specs -id]} {
set DEF_definition_id [dict get $at_specs -id]
@@ -966,7 +968,7 @@ tcl::namespace::eval punk::args {
-anyopts {
set opt_any $v
}
- -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted {
+ -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted {
#review - only apply to certain types?
tcl::dict::set tmp_optspec_defaults $k $v
}
@@ -1012,7 +1014,7 @@ tcl::namespace::eval punk::args {
tcl::dict::set tmp_optspec_defaults $k $v
}
default {
- set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\
+ set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\
-nominsize -nomaxsize -norange -nochoices -nochoicelabels\
-type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\
-regexprepass -regexprefail -regexprefailmsg -validationtransform\
@@ -1050,7 +1052,7 @@ tcl::namespace::eval punk::args {
}
dict set F $fid LEADER_MAX $v
}
- -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase {
+ -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase {
#review - only apply to certain types?
tcl::dict::set tmp_leaderspec_defaults $k $v
}
@@ -1097,8 +1099,9 @@ tcl::namespace::eval punk::args {
}
default {
set known { -min -minvalues -max -maxvalues\
- -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\
- -nominsize -nomaxsize -norange -nochoices -nochoicelabels\
+ -minsize -maxsize -range\
+ -choices -choicegroups -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\
+ -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\
-type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\
-regexprepass -regexprefail -regexprefailmsg -validationtransform\
}
@@ -1135,7 +1138,7 @@ tcl::namespace::eval punk::args {
}
set val_max $v
}
- -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase {
+ -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase {
#review - only apply to certain types?
tcl::dict::set tmp_valspec_defaults $k $v
}
@@ -1182,7 +1185,9 @@ tcl::namespace::eval punk::args {
}
default {
set known { -min -minvalues -max -maxvalues\
- -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\
+ -minsize -maxsize -range\
+ -choices -choicegroups -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\
+ -nocase\
-nominsize -nomaxsize -norange -nochoices -nochoicelabels\
-type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\
-regexprepass -regexprefail -regexprefailmsg -validationtransform\
@@ -1195,6 +1200,10 @@ tcl::namespace::eval punk::args {
}
}
+ seealso {
+ #todo!
+ #like @doc, except displays in footer, multiple - sub-table?
+ }
default {
error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @argdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id"
}
@@ -1321,7 +1330,9 @@ tcl::namespace::eval punk::args {
}
}
}
- -default - -solo - -range - -choices - -choicegroups - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -minsize - -maxsize - -nocase - -optional - -multiple -
+ -default - -solo - -range -
+ -choices - -choicegroups - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -choiceinfo -
+ -minsize - -maxsize - -nocase - -optional - -multiple -
-validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE -
-regexprepass - -regexprefail - -regexprefailmsg
{
@@ -1528,80 +1539,181 @@ tcl::namespace::eval punk::args {
return $argdata_dict
}
- lappend PUNKARGS [list -dynamic 0 {
- @id -id ::punk::args::get_spec
- @cmd -name punk::args::get_definition -help\
- ""
- id -type string -help\
- "identifer for punk::args defintion
- This will usually be a fully-qualifed
- path for a command name"
- patternlist -type list -optional 1 -default * -help\
- "glob-style patterns for retrieving value or switch
- definitions. If ommitted or passed an empty string,
- the raw unresolved definition will be returned as
- a list, including possible leading flags such as
- -dynamic 0|1.
- If specified as * - the entire definition including
- directive lines will be returned in line form.
- (directives are lines beginning with
- @ e.g @id, @cmd etc)
- "
- override_dict -type dict -optional 1 -default "" -help\
- "unimplemented.
- Will allow overriding or adding flags to a returned
- definition line.
- "
- }]
- #rename get_definition ???
- proc get_spec {id args} {
- lassign $args patternlist override_dict
- if {[llength $args] > 2} {
- punk::args::get_by_id ::punk::args::get_spec [list $id {*}$args]
- return
+ #return raw definition list as created with 'define'
+ proc rawdef {id} {
+ variable argdefcache_by_id
+ set realid [real_id $id]
+ #return the raw definition - possibly with unresolved dynamic parts
+ if {![dict exists $argdefcache_by_id $realid]} {
+ return ""
}
- if {[llength $override_dict] % 2 != 0} {
- #malformed dict
- punk::args::get_by_id ::punk::args::get_spec [list $id {*}$args]
+ return [tcl::dict::get $argdefcache_by_id $realid]
+ }
+
+
+ namespace eval argdoc {
+ variable resolved_def_TYPE_CHOICES {* @id @cmd @leaders @opts @values @doc}
+
+ lappend PUNKARGS [list -dynamic 0 [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES] {
+ @id -id ::punk::args::resolved_def
+ @cmd -name punk::args::resolved_def -help\
+ ""
+ @leaders -min 0 -max 0
+ @opts
+ -form -default 0 -help\
+ "UNIMPLEMENTED
+ Ordinal index or name of command form"
+ -type -default * -choices {%TYPECHOICES%} -choiceprefix 0 -multiple 1
+ -override -type dict -optional 1 -default "" -help\
+ "dict of dicts. Key in outer dict is the name of a
+ directive or an argument. Inner dict is a map of
+ overrides/additions (-<flag> <newval>...) for that line.
+ (unimplemented).
+ "
+ @values -min 1 -max -1
+ id -type string -help\
+ "identifer for a punk::args definition
+ This will usually be a fully-qualifed
+ path for a command name"
+ pattern -type string -optional 1 -default * -multiple 1 -help\
+ "glob-style patterns for retrieving value or switch
+ definitions.
+
+ If -type is * and pattern is * the entire definition including
+ directive lines will be returned in line form.
+ (directives are lines beginning with
+ @ e.g @id, @cmd etc)
+
+ if -type is @leaders,@opts or @values matches from that type
+ will be returned.
+
+ if -type is another directive such as @id, @doc etc the
+ patterns are ignored.
+
+ "
+ }]]
+ }
+
+
+ proc resolved_def {args} {
+ set opts [dict create\
+ -type {}\
+ -form 0\
+ -override {}\
+ ]
+ if {[llength $args] < 1} {
+ #must have at least id
+ punk::args::get_by_id ::punk::args::resolved_def $args
return
}
+ set patterns [list]
+
+ #a definition id must not begin with "-"
+ for {set i 0} {$i < [llength $args]} {incr i} {
+ set a [lindex $args $i]
+ if {$a eq "-type"} {
+ incr i
+ dict lappend opts -type [lindex $args $i]
+ } elseif {[string match -* $a]} {
+ incr i
+ dict set opts $a [lindex $args $i]
+ } else {
+ set id [lindex $args $i]
+ set patterns [lrange $args $i+1 end]
+ break
+ }
+ if {$i == [llength $args]-1} {
+ punk::args::get_by_id ::punk::args::resolved_def $args
+ return
+ }
+ }
+ if {![llength $patterns]} {
+ set patterns [list *]
+ }
+ dict for {k v} $opts {
+ switch -- $k {
+ -form - -type - -override {}
+ default {
+ punk::args::get_by_id ::punk::args::resolved_def $args
+ return
+ }
+ }
+ }
+ set typelist [dict get $opts -type]
+ if {[llength $typelist] == 0} {
+ set typelist {*}
+ }
+ foreach type $typelist {
+ if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} {
+ punk::args::get_by_id ::punk::args::resolved_def $args
+ return
+ }
+ }
variable argdefcache_by_id
set realid [real_id $id]
+
if {$realid ne ""} {
- if {$patternlist eq ""} {
- #return the raw definition - possibly with unresolved dynamic parts
- return [tcl::dict::get $argdefcache_by_id $realid]
- } else {
- set deflist [tcl::dict::get $argdefcache_by_id $realid]
- set result ""
- set specdict [uplevel 1 [list ::punk::args::define {*}$deflist]]
- set arg_info [dict get $specdict ARG_INFO]
- foreach pat $patternlist {
- if {[string match $pat @id]} {
+ set deflist [tcl::dict::get $argdefcache_by_id $realid]
+ set result ""
+ set specdict [uplevel 1 [list ::punk::args::define {*}$deflist]]
+ set arg_info [dict get $specdict ARG_INFO]
+ set argtypes [dict create @opts option @leaders leader @values value]
+ foreach type $typelist {
+ switch -exact -- $type {
+ * {
+ append result \n "@id -id [dict get $specdict id]"
+ append result \n "@cmd [dict get $specdict cmd_info]"
+ append result \n "@doc [dict get $specdict doc_info]"
+ foreach tp {leader option value} {
+ foreach pat $patterns {
+ set matches [dict keys $arg_info $pat]
+ foreach m $matches {
+ set def [dict get $arg_info $m]
+ if {[dict get $def -ARGTYPE] eq $tp} {
+ set def [dict remove $def -ARGTYPE]
+ append result \n "$m $def"
+ }
+ }
+ }
+ }
+
+ }
+ @id {
#only a single id record can exist
append result \n "@id -id [dict get $specdict id]"
}
- if {[string match $pat @cmd]} {
+ @cmd {
#only a single @cmd record can exist
#merged if multiple in original def (?)
append result \n "@cmd [dict get $specdict cmd_info]"
}
- #todo @leaders, @opts, @values lines
- #can be multiple of each. We need to preserve order and interleave
- #with any matching arg_info results.
- #requires storing more info in the internal spec dictionary
- set matches [dict keys $arg_info $pat]
- foreach m $matches {
- set def [dict get $arg_info $m]
- set def [dict remove $def -ARGTYPE]
- append result \n "$m $def"
+ @doc {
+ #only a single @doc record can exist
+ append result \n "@doc [dict get $specdict doc_info]"
+ }
+ @leaders - @opts - @values {
+ #option,
+ foreach pat $patterns {
+ set matches [dict keys $arg_info $pat]
+ foreach m $matches {
+ set def [dict get $arg_info $m]
+ if {[dict get $def -ARGTYPE] eq [dict get $argtypes $type]} {
+ set def [dict remove $def -ARGTYPE]
+ append result \n "$m $def"
+ }
+ }
+ }
+ }
+ default {
}
}
- return $result
}
+
+ return $result
}
}
+
proc get_spec_values {id {patternlist *}} {
variable argdefcache_by_id
set realid [real_id $id]
@@ -1636,13 +1748,14 @@ tcl::namespace::eval punk::args {
#proc get_spec_opts ??
proc get_def {id} {
- if {[id_exists $id]} {
- return [define {*}[get_spec $id]]
- }
+ return [define {*}[rawdef $id]]
+ #if {[id_exists $id]} {
+ # return [define {*}[rawdef $id]]
+ #}
}
proc is_dynamic {id} {
- set spec [get_spec $id]
- return [expr {[lindex $spec 0] eq "-dynamic" && [lindex $spec 1]} ]
+ set deflist [rawdef $id]
+ return [expr {[lindex $deflist 0] eq "-dynamic" && [lindex $deflist 1]} ]
}
variable aliases
@@ -1661,6 +1774,8 @@ tcl::namespace::eval punk::args {
variable aliases
return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $argdefcache_by_id $match]]
}
+
+ #we don't automatically test for (autodef)$id - only direct ids and aliases
proc id_exists {id} {
variable argdefcache_by_id
variable aliases
@@ -1694,6 +1809,9 @@ tcl::namespace::eval punk::args {
return $id
} else {
if {![llength [update_definitions]]} {
+ if {[tcl::dict::exists $argdefcache_by_id (autodef)$id]} {
+ return (autodef)$id
+ }
return ""
} else {
if {[tcl::dict::exists $aliases $id]} {
@@ -1702,6 +1820,9 @@ tcl::namespace::eval punk::args {
if {[tcl::dict::exists $argdefcache_by_id $id]} {
return $id
}
+ if {[tcl::dict::exists $argdefcache_by_id (autodef)$id]} {
+ return (autodef)$id
+ }
return ""
}
}
@@ -1797,7 +1918,7 @@ tcl::namespace::eval punk::args {
@values -min 0 -max 0
}]
proc test_get_dict {args} {
- punk::args::get_dict {*}[punk::args::get_spec ::punk::args::test1] $args
+ punk::args::get_dict {*}[punk::args::rawdef ::punk::args::test1] $args
}
proc test_get_by_id {args} {
punk::args::get_by_id ::punk::args::test1 $args
@@ -2558,7 +2679,7 @@ tcl::namespace::eval punk::args {
mechanism and call this as necessary.
"
-return -default table -choices {string table tableobject}
- } {${[punk::args::get_spec ::punk::args::arg_error -scheme]}} {
+ } {${[punk::args::resolved_def -type @opts ::punk::args::arg_error -scheme]}} {
@values -min 0 -max 1
id -help\
@@ -2568,7 +2689,7 @@ tcl::namespace::eval punk::args {
proc usage {args} {
lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received
set id [dict get $values id]
- set definitionlist [get_spec $id]
+ set definitionlist [rawdef $id]
if {[llength $definitionlist] == 0} {
error "punk::args::usage - no such id: $id"
}
@@ -2589,7 +2710,7 @@ tcl::namespace::eval punk::args {
#deprecate?
proc get_by_id {id arglist} {
- set definitionlist [punk::args::get_spec $id]
+ set definitionlist [punk::args::rawdef $id]
if {[llength $definitionlist] == 0} {
error "punk::args::get_by_id - no such id: $id"
}
@@ -2633,6 +2754,25 @@ tcl::namespace::eval punk::args {
-errorstyle -type string -default enhanced -choices {enhanced standard minimal}
@values -min 3
sep -optional 0 -choices "--"
+
+
+ @form -form withid -synopsis "parse ?-form {int|<formname>...}? ?-errorstyle <choice>? -- withid $id"
+ withid -type literal -help\
+ "The literal value 'withid'"
+ id -type string -help\
+ "id of punk::args definition for a command"
+
+
+ @form -form withdef -synopsis "parse ?-form {int|<formname>...}? ?-errorstyle <choice>? -- withdef $def ?$def?"
+ withdef -type literal -help\
+ "The literal value 'withdef'"
+ def -type string -multiple 1 -optional 0 -help\
+ "Each remaining argument is a block of text
+ defining argument definitions.
+ As a special case, -dynamic <bool> may be
+ specified as the 1st 2 arguments. These are
+ not treated as an indicator to punk::args
+ about how to process the definition."
}]
proc parse {args} {
@@ -2669,7 +2809,8 @@ tcl::namespace::eval punk::args {
return "parse [llength $arglist] args withid $id, options:$opts"
}
withdef {
- if {[llength [lrange $args $split+3 end]] < 1} {
+ set deflist [lrange $args $split+3 end]
+ if {[llength $deflist] < 1} {
error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'"
}
return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts"
@@ -4173,7 +4314,7 @@ tcl::namespace::eval punk::args::lib {
# set PUNKARGS ""
#}
-lappend ::punk::args::register::NAMESPACES ::punk::args ::punk::args::lib
+lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm
index 353d1f65..1381af87 100644
--- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm
+++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm
@@ -890,7 +890,7 @@ namespace eval punk::lib {
set cur [lmap a_l $list_l { lindex $a_l 0 }]
set list_l [lmap a_l $list_l { lrange $a_l 1 end }]
- if {[join $cur {}] == {}} {
+ if {[join $cur {}] eq {}} {
break
}
lappend zip_l $cur
diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm
index d9d36291..7d59eb35 100644
--- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm
+++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm
@@ -687,50 +687,34 @@ namespace eval punk::mix::cli {
package require punk::zip
set zipfile $buildfolder/$basename-$module_build_version.zip ;#ordinary zip file (deflate)
- set zipmechanism "punk::zip" ;#todo - get choice of mechanism from config
+ #zipfs mkzip does exactly what we need anyway in this case
+ #unfortunately it's not available in all Tclsh versions we might be running..
+ if {[llength [info commands zipfs]]} {
+ #zipfs mkzip (2025) doesn't add entries for folders.
+ #(Therefore no timestamps)
+ #zip reading utils generally intuit their existence and display them - but often an editor can't add comments to them
+ set wd [pwd]
+ cd $buildfolder
+ puts "zipfs mkzip $zipfile #modpod-$basename-$module_build_version"
+ zipfs mkzip $zipfile #modpod-$basename-$module_build_version
+ cd $wd
- switch -- $zipmechanism {
- "punk::zip" {
- #use -base $buildfolder so that -directory is included in the archive - the modpod stub relies on this - and extraction would be potentially messy otherwise
- punk::zip::mkzip -base $buildfolder -directory $buildfolder/#modpod-$basename-$module_build_version -- $zipfile *
- }
- "zipfs" {
- if {[llength [info commands zipfs]]} {
- #'zipfs mkzip' does we need in this case
- #unfortunately it's not available in all Tclsh versions we might be running..
- #
- #sidenote:
- # as at 2024-10 - zipfs mkimg seems to create an apparently working zip - but on windows not updatable with 'zip -A' or 7z etc
- #This is because offsets are file relative vs archive relative
- #(pkzip & info-zip seem to prefer file-relative ie offsets that have been adjusted after cat headerfile zipfile > somekit
- #this isn't an issue for 'mkzip' here though as we don't yet have a headerfile so offset file vs archive are the same.
-
- set wd [pwd]
- cd $buildfolder
- puts "zipfs mkzip $zipfile #modpod-$basename-$module_build_version"
- zipfs mkzip $zipfile #modpod-$basename-$module_build_version
- cd $wd
- } else {
- #TODO - review punk::zip::mkzip and/or external zip to provide a fallback?
- set had_error 1
- lappend notes "zipfs_unavailable"
- puts stderr "WARNING: zipfs unavailable can't build $modulefile"
- }
- }
- default {
- set had_error 1
- lappend notes "unrecognized_zipmechanism"
- puts stderr "WARNING: no such zipmechanism '$zipmechanism' can't build $modulefile"
- }
- }
-
- if {[catch {package require modpod} errM]} {
- set had_error 1
- lappend notes "modpod_unavailable"
- puts stderr "WARNING: modpod package unavailable can't build $modulefile"
+ } else {
+ #use -base $buildfolder so that -directory is included in the archive - the modpod stub relies on this - and extraction would be potentially messy otherwise
+ #put in an archive-level comment to aid in debugging
+ #punk
+ punk::zip::mkzip -base $buildfolder -directory $buildfolder/#modpod-$basename-$module_build_version -- $zipfile *
+ #punk::zip::mkzip stores permissions - (unix style) - which zipfs mkzip doesn't
+ #Directory ident in zipfs relies on folders ending with trailing slash - if missing, it misidentifies dirs as files.
+ #(ie it can't use permissions/attributes alone to determine directory vs file)
+ #TODO - review punk::zip::mkzip and/or external zip to provide a fallback?
+ #JMN25
+
+ #set had_error 1
+ #lappend notes "zipfs_unavailable"
+ #puts stderr "WARNING: zipfs unavailable can't build $modulefile"
}
-
- if {!$had_error} {
+ if {!$had_error && [file exists $zipfiles]} {
package require modpod
modpod::lib::make_zip_modpod $zipfile $modulefile
}
diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm
index 6b1923b1..fa9e8d7c 100644
--- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm
+++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm
@@ -22,7 +22,7 @@ package require punk::path ;# for treefilenames, relative
package require punk::repo
package require punk::docgen ;#inline doctools - generate doctools .man files at src/docgen prior to using kettle to producing .html .md etc
package require punk::mix::cli ;#punk::mix::cli::lib used for kettle_call
-#package require punk::mix::util ;#for path_relative
+#package require punkcheck ;#for path_relative
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm
index 6235224a..8fa9ce89 100644
--- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm
+++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm
@@ -1995,7 +1995,7 @@ tcl::namespace::eval punk::ns {
-return -type string -default table -choices {string table tableobject}
- } {${[punk::args::get_spec ::punk::args::arg_error -scheme]}} {
+ } {${[punk::args::resolved_def -type @opts ::punk::args::arg_error -scheme]}} {
-- -type none -help\
"End of options marker
diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm
index 5f7dba71..03578a56 100644
--- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm
+++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm
@@ -119,6 +119,7 @@ tcl::namespace::eval punk::packagepreference {
#*** !doctools
#[call [fun install]]
#[para]Override ::package builtin (or the current implementation if it has already been renamed/overridden) to check for and prefer lowercase packages/modules
+ #[para](todo - check info loaded and restrict to existing version as determined from dll/so?)
#[para]The overriding package command will call whatever implementation was in place before install to do the actual work - once it has modified 'package require' names to lowercase.
#[para]This is intended to be in alignment with tip 590 "Recommend lowercase Package Names"
#[para] https://core.tcl-lang.org/tips/doc/trunk/tip/590.md
@@ -152,40 +153,83 @@ tcl::namespace::eval punk::packagepreference {
#despite preference for lowercase - we need to handle packages that insist on providing as uppercase
#(e.g we will still need to handle things like: package provide Tcl 8.6)
#Where the package is already provided uppercase we shouldn't waste time deferring to lowercase
+ set is_exact 0
if {[lindex $args 1] eq "-exact"} {
set pkg [lindex $args 2]
- set vwant [lindex $args 3]
- if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} {
- #although we could shortcircuit using vsatisfies to return the ver
- #we should instead pass through to COMMANDSTACKNEXT so as not to interfere with whatever it does.
- return [$COMMANDSTACKNEXT {*}$args]
-
- #if {$vwant eq "" || [$COMMANDSTACKNEXT vsatisfies $ver $vwant]} {
- # return $ver
- #} else {
- # #package already provided with a different version.. we will defer to underlying implementation to return the standard error
- # return [$COMMANDSTACKNEXT {*}$args]
- #}
- }
+ set vwant [lindex $args 3]-[lindex $args 3]
+ set is_exact 1
} else {
set pkg [lindex $args 1]
- set vwant [lindex $args 2]
- if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} {
- return [$COMMANDSTACKNEXT {*}$args]
- #if {$vwant eq "" || [$COMMANDSTACKNEXT vsatisfies $ver $vwant]} {
- # return $ver
- #}
+ set vwant [lrange $args 2 end] ;#rare - but version can be a list of options
+ if {[llength $vwant] == 1 && [string first - [lindex $vwant 0]] > 0} {
+ #only one version - and it has a dash
+ lassign [split [lindex $vwant 0] -] a b
+ if {$a eq $b} {
+ #string compare version nums (can contain dots and a|b)
+ set is_exact 1
+ }
+ }
+ }
+ if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} {
+ #although we could shortcircuit using vsatisfies to return the ver
+ #we should instead pass through to COMMANDSTACKNEXT so as not to interfere with whatever it does.
+ #e.g a package require logger further down the commandstack
+ return [$COMMANDSTACKNEXT {*}$args]
+ }
+
+ if {!$is_exact && [llength $vwant] <= 1 } {
+ #required version unspecified - or specified singularly
+ # ---------------------------------------------------------------
+ #An attempt to detect dll/so loaded and try to load same version
+ set pkgloadedinfo [lsearch -inline -index 1 [info loaded] $pkg]
+ if {![llength $pkgloadedinfo]} {
+ if {[regexp {[A-Z]} $pkg]} {
+ set pkgloadedinfo [lsearch -inline -index 1 [info loaded] [string tolower $pkg]]
+ if {![llength $pkgloadedinfo]} {
+ set pkgloadedinfo [lsearch -inline -index 1 [info loaded] [string totitle $pkg]]
+ }
+ }
+ }
+
+ if {[llength $pkgloadedinfo]} {
+ puts stderr "--> pkg not present but shared object seems to be loaded: $pkgloadedinfo"
+ lassign $pkgloadedinfo path name
+ set lcpath [string tolower $path]
+ set obj [file tail $lcpath]
+ if {[string match tcl9* $obj]} {
+ set obj [string range $obj 4 end]
+ } elseif {[string match lib* $obj]} {
+ set obj [string range $obj 3 end]
+ }
+ set pkginfo [file rootname $obj]
+ #e.g Thread2.8.8
+ if {[regexp {^([a-zA-Z\-]+)(.*)} $pkginfo _match lname lversion]} {
+ if {[string tolower $lname] eq [string tolower $pkg]} {
+ #name matches pkg
+ #hack for known dll version mismatch
+ if {[string tolower $pkg] eq "thread" && $lversion eq "30b3"} {
+ set lversion 3.0b3
+ }
+ if {[llength $vwant] == 1} {
+ #todo - still check vsatisfies - report a conflict? review
+ }
+ return [$COMMANDSTACKNEXT require $pkg $lversion-$lversion]
+ }
+ }
}
}
+ # ---------------------------------------------------------------
+ set pkgloadedinfo [lsearch -inline -index 1 [info loaded] $pkg]
+
if {[regexp {[A-Z]} $pkg]} {
#only apply catch & retry if there was a cap - otherwise we'll double try for errors unrelated to capitalisation
- if {[catch {$COMMANDSTACKNEXT {*}[string tolower $args]} v]} {
- return [$COMMANDSTACKNEXT {*}$args]
+ if {[catch {$COMMANDSTACKNEXT require [string tolower $pkg] {*}$vwant} v]} {
+ return [$COMMANDSTACKNEXT require $pkg {*}$vwant]
} else {
return $v
}
} else {
- return [$COMMANDSTACKNEXT {*}$args]
+ return [$COMMANDSTACKNEXT require $pkg {*}$vwant]
}
}
default {
diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm
index b3693f71..6158fdce 100644
--- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm
+++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm
@@ -137,6 +137,13 @@ tcl::namespace::eval punk::repl::codethread {
variable run_command_cache
+ #Use interp exists instead..
+ #if {[catch {interp children}]} {
+ # #8.6.10 doesn't have it.. when was it introduced?
+ #} else {
+
+ #}
+
proc is_running {} {
variable running
return $running
@@ -150,7 +157,7 @@ tcl::namespace::eval punk::repl::codethread {
#expecting to be called from a thread::send in parent repl - ie in the toplevel interp so that the sub-interp "code" is available
#if a thread::send is done from the commandline in a codethread - Tcl will
- if {"code" ni [interp children] || ![info exists replthread_cond]} {
+ if {![interp exists code] || ![info exists replthread_cond]} {
#in case someone tries calling from codethread directly - don't do anything or change any state
#(direct caller could create an interp named code at the level "" -> "code" -"code" and add a replthread_cond value to avoid this check - but it probably won't do anything useful)
#if called directly - the context will be within the first 'code' interp.
diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm
index 11ae9ab2..2895b024 100644
--- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm
+++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm
@@ -179,26 +179,55 @@ tcl::namespace::eval punk::zip {
# punk::zip::walk -exclude {CVS/* *~.#*} library
#}]
+ #todo: -relative 0|1 flag?
set argd [punk::args::get_dict {
@id -id ::punk::zip::walk
- @cmd -name punk::zip::walk
+ @cmd -name punk::zip::walk -help\
+ "Walk the directory structure starting at base/<-subpath>
+ and return a list of the files and folders encountered.
+ Resulting paths are relative to base unless -resultrelative
+ is supplied.
+ Folder names will end with a trailing slash.
+ "
+ -resultrelative -optional 1 -help\
+ "Resulting paths are relative to this value.
+ Defaults to the value of base. If empty string
+ is given to -resultrelative the paths returned
+ are effectively absolute paths."
-excludes -default "" -help "list of glob expressions to match against files and exclude"
- -subpath -default ""
+ -subpath -default "" -help\
+ "May contain glob chars for folder elements"
@values -min 1 -max -1
base
fileglobs -default {*} -multiple 1
} $args]
set base [dict get $argd values base]
- set fileglobs [dict get $argd values fileglobs]
+ set fileglobs [dict get $argd values fileglobs]
set subpath [dict get $argd opts -subpath]
set excludes [dict get $argd opts -excludes]
+ set received [dict get $argd received]
set imatch [list]
foreach fg $fileglobs {
lappend imatch [file join $subpath $fg]
}
+ if {![dict exists $received -resultrelative]} {
+ set relto $base
+ set prefix ""
+ } else {
+ set relto [file normalize [dict get $argd opts -resultrelative]]
+ if {$relto ne ""} {
+ if {![Path_a_atorbelow_b $base $relto]} {
+ error "punk::zip::walk base must be at or below -resultrelative value (backtracking not currently supported)"
+ }
+ set prefix [Path_strip_alreadynormalized_prefixdepth $base $relto]
+ } else {
+ set prefix $base
+ }
+ }
+
set result {}
#set imatch [file join $subpath $match]
set files [glob -nocomplain -tails -types f -directory $base -- {*}$imatch]
@@ -210,7 +239,7 @@ tcl::namespace::eval punk::zip {
break
}
}
- if {!$excluded} {lappend result $file}
+ if {!$excluded} {lappend result [file join $prefix $file]}
}
foreach dir [glob -nocomplain -tails -types d -directory $base -- [file join $subpath *]] {
set subdir_entries [walk -subpath $dir -excludes $excludes $base {*}$fileglobs]
@@ -218,7 +247,7 @@ tcl::namespace::eval punk::zip {
#NOTE: trailing slash required for entries to be recognised as 'file type' = "directory"
#This is true for 2024 Tcl9 mounted zipfs at least. zip utilities such as 7zip seem(icon correct) to recognize dirs with or without trailing slash
#Although there are attributes on some systems to specify if entry is a directory - it appears trailing slash should always be used for folder names.
- set result [list {*}$result "$dir/" {*}$subdir_entries]
+ set result [list {*}$result "[file join $prefix $dir]/" {*}$subdir_entries]
}
}
return $result
@@ -554,7 +583,9 @@ tcl::namespace::eval punk::zip {
-comment -default ""\
-help "An optional comment for the archive"
-directory -default ""\
- -help "The new zip archive will scan for contents within this folder or current directory if not provided."
+ -help "The new zip archive will scan for contents within this folder or current directory if not provided.
+ Note that this will
+ "
-base -default ""\
-help "The new zip archive will be rooted in this directory if provided
it must be a parent of -directory or the same path as -directory"
@@ -605,6 +636,7 @@ tcl::namespace::eval punk::zip {
set base $opts(-directory)
set relpath ""
}
+ #will pick up intermediary folders as paths (ending with trailing slash)
set paths [walk -exclude $opts(-exclude) -subpath $relpath -- $base {*}[dict get $argd values globs]]
set norm_filename [file normalize $filename]
@@ -654,6 +686,8 @@ tcl::namespace::eval punk::zip {
}
}
} else {
+ #NOTE that we don't add intermediate folders when creating an archive without using the -directory flag!
+ #ie - only the exact *files* matching the glob are stored.
set paths [list]
set dir [pwd]
if {$opts(-base) ne ""} {
@@ -712,7 +746,7 @@ tcl::namespace::eval punk::zip {
if {$opts(-offsettype) eq "archive"} {
set dataStartOffset [tell $zf] ;#the overall file offset of the start of archive-data //JMN 2024
} else {
- set dataStartOffset 0 ;#offsets relative to file - the zipfs mkzip way :/
+ set dataStartOffset 0 ;#offsets relative to file - the (old) zipfs mkzip way :/
}
set count 0
diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm
index 32450e55..56651d21 100644
--- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm
+++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm
@@ -96,42 +96,60 @@ tcl::namespace::eval textblock {
variable use_hash ;#framecache
set use_hash none ;#slightly faster but uglier layout for viewing frame_cache display
- #if {![catch {package require sha1}]} {
- # set use_hash sha1
- #} elseif {![catch {package require md5}]} {
- # set use_hash md5
- #} else {
- # set use_hash none
- #}
- proc use_hash {args} {
- set choices [list none]
- set unavailable [list]
- set pkgs [package names]
- if {"md5" in $pkgs} {
- lappend choices md5
- } else {
- lappend unavailable md5
+ namespace eval argdoc {
+ proc hash_algorithm_choices_and_help {} {
+ set choices [list none]
+ set unavailable [list]
+ set unloaded [dict create]
+ set algorithm_packages {md5 sha1 sha256}
+ foreach p $algorithm_packages {
+ if {[package provide $p] eq ""} {
+ dict set unloaded $p ""
+ }
+ }
+ if {[dict size $unloaded]} {
+ set allpkgs [package names] ;#only retrieve once
+ foreach p $algorithm_packages {
+ if {[dict exists $unloaded $p]} {
+ #not loaded - but check if available
+ if {$p in $allpkgs} {
+ lappend choices $p
+ } else {
+ lappend unavailable $p
+ }
+ } else {
+ lappend choices $p
+ }
+ }
+ } else {
+ lappend choices {*}$algorithm_packages
+ set unavailable ""
+ }
+
+ set choicemsg ""
+ if {[llength $unavailable]} {
+ set choicemsg " (unavailable packages: $unavailable)"
+ }
+ #return $choices
+ return " -choices \{$choices\} -help {algorithm choice $choicemsg} "
}
- if {"sha1" in $pkgs} {
- lappend choices sha1
- } else {
- lappend unavailable sha1
- }
- set choicemsg ""
- if {[llength $unavailable]} {
- set choicemsg " (unavailable packages: $unavailable)"
- }
- set argd [punk::args::get_dict [tstr -return string {
- @id -id ::textblock::use_hash
- @cmd -name "textblock::use_hash" -help\
- "Hashing algorithm to use for framecache lookup.
- 'none' may be slightly faster but less compact
- when viewing textblock::framecache"
- @values -min 0 -max 1
- hash_algorithm -choices {${$choices}} -optional 1 -help\
- "algorithm choice ${$choicemsg}"
- }] $args]
+ }
+
+ # hash_algorithm -optional 1 -choices {${[::textblock::argdoc::hash_algorithm_choices]}} -help\
+ # "algorithm choice"
+
+ punk::args::define -dynamic 1 {
+ @id -id ::textblock::use_hash
+ @cmd -name "textblock::use_hash" -help\
+ "Hashing algorithm to use for framecache lookup.
+ 'none' may be slightly faster but less compact
+ when viewing textblock::framecache"
+ @values -min 0 -max 1
+ hash_algorithm -optional 1 ${[::textblock::argdoc::hash_algorithm_choices_and_help]}
+ }
+ proc use_hash {args} {
+ set argd [punk::args::get_by_id ::textblock::use_hash $args]
variable use_hash
if {![dict exists $argd received hash_algorithm]} {
return $use_hash
@@ -4367,6 +4385,15 @@ tcl::namespace::eval textblock {
"
-return -default table -choices {table tableobject}
+ -table -default "" -type string\
+ -help "existing table object to use"
+ -action -default "append" -choices {append replace}\
+ -help "row insertion method if existing -table is supplied
+ if append is chosen the new values will always start at the first column"
+ -title -type string -help\
+ "Title to display overlayed on top edge of table.
+ Will not be visible if -show_edge is false"
+ -titlealign -type string -choices {left centre right}
-frametype -default "light" -type dict -choices {${$FRAMETYPES}} -choicerestricted 0\
-help "frame type or dict for custom frame"
-show_edge -default "" -type boolean\
@@ -4377,10 +4404,21 @@ tcl::namespace::eval textblock {
-show_hseps -default "" -type boolean\
-help "Show horizontal table separators
(default 0 if no existing -table supplied)"
- -table -default "" -type string\
- -help "existing table object to use"
-colheaders -default "" -type list\
- -help "list of lists. list of column header values. Outer list must match number of columns"
+ -help {list of lists. list of column header values. Outer list must match number of columns.
+ A table
+ e.g single header row: -colheaders {{column_a} {column_b} {column_c}}
+ e.g 2 header rows: -colheaders {{column_a "nextrow test"} {column_b} {column_c}}
+ Note that each element of the outer list is itself a list so:
+ -colheaders {"column a" "column b" "column c"}
+ Is likely not the right format if it was intended to have a single header row where the
+ column titles contain spaces.
+ The correct syntax for that would be:
+ -colheaders {{"column a"} {"column b"} {"column c"}}
+ For spanning header cells - use 'set t [list_as_table -return tableobject ...]'
+ and then something like:
+ $t configure_header 1 -colspans {3 0 0}; $t print
+ }
-header -default "" -type list -multiple 1\
-help "Each supplied -header argument is a header row.
The number of values for each must be <= number of columns"
@@ -4388,9 +4426,6 @@ tcl::namespace::eval textblock {
-help "Whether to show a header row.
Omit for unspecified/automatic,
in which case it will display only if -headers list was supplied."
- -action -default "append" -choices {append replace}\
- -help "row insertion method if existing -table is supplied
- if append is chosen the new values will always start at the first column"
-columns -default "" -type integer\
-help "Number of table columns
Will default to 2 if not using an existing -table object"
@@ -4404,6 +4439,7 @@ tcl::namespace::eval textblock {
set argd [punk::args::get_by_id ::textblock::list_as_table $args]
set opts [dict get $argd opts]
+ set received [dict get $argd received]
set datalist [dict get $argd values datalist]
set existing_table [dict get $opts -table]
@@ -4560,6 +4596,12 @@ tcl::namespace::eval textblock {
}
$t add_row $row
}
+ if {"-title" in $received} {
+ $t configure -title [dict get $opts -title]
+ }
+ if {"-titlealign" in $received} {
+ $t configure -titlealign [dict get $opts -titlealign]
+ }
#puts stdout $rowdata
if {[tcl::dict::get $opts -return] eq "table"} {
set result [$t print]
@@ -5895,7 +5937,16 @@ tcl::namespace::eval textblock {
append out [textblock::join -- $punks $cpunks] \n
set 2frames_a [textblock::join -- [textblock::frame -checkargs 0 $cpunks] [textblock::frame -checkargs 0 $punks]]
append out $2frames_a \n
- set 2frames_b [textblock::join -- [textblock::frame -checkargs 0 -ansiborder $cyanb -title "plainpunks" $punks] [textblock::frame -checkargs 0 -ansiborder $greenb -title "fancypunks" $cpunks]]
+ set 2frames_b [textblock::join --\
+ [textblock::frame -checkargs 0 -ansiborder $cyanb\
+ -title "plainpunks" $punks]\
+ [textblock::frame -checkargs 0 -ansiborder $greenb\
+ -title "fancy"\
+ -titlealign right\
+ -subtitle "punks"\
+ -subtitlealign left\
+ $cpunks]\
+ ]
append out [textblock::frame -checkargs 0 -title "punks" $2frames_b\n$RST$2frames_a] \n
set punkdeck [overtype::right [overtype::left [textblock::frame -checkargs 0 -ansiborder [a+ green bold] -type heavy -title ${redb}PATTERN$RST -subtitle ${redb}PUNK$RST $prightair_cyanb] "$blueb\n\n\P\nU\nN\nK$RST"] "$blueb\n\nD\nE\nC\nK"]
set spantable [[spantest] print]
@@ -7503,20 +7554,41 @@ tcl::namespace::eval textblock {
@id -id ::textblock::frame_cache
@cmd -name textblock::frame_cache -help\
"Display or clear the frame cache."
- -action -default {} -choices {clear} -help\
- "Clear the textblock::frame_cache dictionary"
-pretty -default 1 -help\
- "Use 'pdict textblock::frame_cache */*' for prettier output"
- @values -min 0 -max 0
+ "Uses 'pdict textblock::frame_cache */*' for prettier output
+ Either way this is set, output requires long lines and may
+ still wrap in an ugly manner. Try 'textblock::use_cache md5'
+ to shorten the argument display and reduce wrapping.
+ "
+ @values -min 0 -max 1
+ action -default {display} -choices {clear size info display} -choicelabels {
+ clear "Clear the textblock::frame_cache dictionary."
+ } -help "Perform an action on the frame cache."
}
proc frame_cache {args} {
set argd [punk::args::get_by_id ::textblock::frame_cache $args]
- set action [dict get $argd opts -action]
-
- if {$action ni [list clear ""]} {
- error "frame_cache action '$action' not understood. Valid actions: clear"
- }
+ set action [dict get $argd values action]
variable frame_cache
+ switch -- $action {
+ clear {
+ set size [dict size $frame_cache]
+ set frame_cache [tcl::dict::create]
+ return "frame_cache cleared $size entries"
+ }
+ size {
+ return [dict size $frame_cache]
+ }
+ info {
+ return [dict info $frame_cache]
+ }
+ display {
+ #fall through
+ }
+ default {
+ #assert - unreachable - punk::args should have validated
+ error "frame_cache -action '$action' not understood. Valid actions: clear size info display"
+ }
+ }
if {[dict get $argd opts -pretty]} {
set out [pdict -chan none frame_cache */*]
} else {
@@ -7544,10 +7616,6 @@ tcl::namespace::eval textblock {
append out \n ;# frames used to build tables often have joins - keep a line in between for clarity
}
}
- if {$action eq "clear"} {
- set frame_cache [tcl::dict::create]
- append out \nCLEARED
- }
return $out
}
@@ -7608,9 +7676,11 @@ tcl::namespace::eval textblock {
May contain ANSI - no trailing reset required.
${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing
e.g 2: frame -title [a+ red underline]MyThing${[textblock::RST]}"
+ -titlealign -default "centre" -choices {left centre right}
-subtitle -default "" -type string -regexprefail {\n}\
-help "Frame subtitle placed on bottombar - no newlines
May contain Ansi - no trailing reset required."
+ -subtitlealign -default "centre" -choices {left centre right}
-width -default "" -type int\
-help "Width of resulting frame including borders.
If omitted or empty-string, the width will be determined automatically based on content."
@@ -7667,7 +7737,9 @@ tcl::namespace::eval textblock {
-boxmap {}\
-joins [list]\
-title ""\
+ -titlealign "centre"\
-subtitle ""\
+ -subtitlealign "centre"\
-width ""\
-height ""\
-ansiborder ""\
@@ -7710,7 +7782,7 @@ tcl::namespace::eval textblock {
set k2 [tcl::prefix::match -error "" $optnames $k]
switch -- $k2 {
-etabs - -type - -boxlimits - -boxmap - -joins
- - -title - -subtitle - -width - -height
+ - -title - -titlealign - -subtitle - -subtitlealign - -width - -height
- -ansiborder - -ansibase
- -blockalign - -textalign - -ellipsis
- -crm_mode
@@ -7879,6 +7951,10 @@ tcl::namespace::eval textblock {
package require sha1
set hash [sha1::sha1 [encoding convertto utf-8 $hashables]]
}
+ sha256 {
+ package require sha256
+ set hash [sha2::sha256 [encoding convertto utf-8 $hashables]]
+ }
md5 {
package require md5
if {[package vsatisfies [package present md5] 2- ] } {
@@ -7887,7 +7963,7 @@ tcl::namespace::eval textblock {
set hash [md5::md5 [encoding convertto utf-8 $hashables]]
}
}
- none {
+ default {
set hash $hashables
}
}
@@ -8246,12 +8322,24 @@ tcl::namespace::eval textblock {
}
if {$opt_title ne ""} {
- set topbar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $tbar $opt_title] ;#overtype supports gx0 on/off
+ set titlealign [dict get $opts -titlealign]
+ set titlealignfull [tcl::prefix::match -error "" {left centre right} $titlealign]
+ if {$titlealignfull ni {left centre right}} {
+ error "textblock::frame -titlealign must be one of {left centre right} or a unique prefix thereof. Received $titlealign"
+ }
+ #set topbar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $tbar $opt_title] ;#overtype supports gx0 on/off
+ set topbar [overtype::block -blockalign $titlealignfull -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 $tbar $opt_title] ;#overtype supports gx0 on/off
} else {
set topbar $tbar
}
if {$opt_subtitle ne ""} {
- set bottombar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $bbar $opt_subtitle] ;#overtype supports gx0 on/off
+ set titlealign [dict get $opts -subtitlealign]
+ set titlealignfull [tcl::prefix::match -error "" {left centre right} $titlealign]
+ if {$titlealignfull ni {left centre right}} {
+ error "textblock::frame -subtitlealign must be one of {left centre right} or a unique prefix thereof. Received $titlealign"
+ }
+ #set bottombar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $bbar $opt_subtitle] ;#overtype supports gx0 on/off
+ set bottombar [overtype::block -blockalign $titlealignfull -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 $bbar $opt_subtitle] ;#overtype supports gx0 on/off
} else {
set bottombar $bbar
}
diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/zipper-0.12.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/zipper-0.12.tm
index 6bf5e87eacb2aef2c5a678ce61f5af937be974d7..080e7da9391e33c62e5e9c49bd5c3006ae2e5f48 100644
GIT binary patch
delta 1668
zcmV-~27CGTO!rK%*BJ@4nmt-fc8oQsli(Rd6}x2jc563vsf%+}In23)G{CHd#A=f{
z8XE%t^pjQ^+W~u%G8;kxRFicZivh2*0UQhg0g;mq9i)HMZ+5AGE+0Evzy?Vinh{l;
zG4hSkQ{c?4YN7T<R#)=qFUKFQUZb{fb_U`xYQR0G$vKxf!{Nl?Zc`&Ttbm^Vv6@lA
z-;adYi^m1?Chrn*w*sK<S&=`bZrwWf3v2*P6fi)l$LGXwI1kYbN%mCn6gkSvm0UM-
zAZtC@QYU{BV`GB|n`?Abw}my*E5P~gJ92jqULNMZ8#sp{xED;ZDg85+UOJ*v*kr+q
z<pdDJ9&=<?!#R=@_aoBTsi9Cojafxg+qxLTz|T0M=u@P}6r{nEeu<g3{G^FI4Jvlo
zl8THHl?cF>FX6enJEW8hg@;45&oTmNSAV>9M3;Y`r`UpFE`i<Oe81mUgjZv6sdtCH
zqRi&E<F&H=lkLA2iO~`y2oGC<eR?QC^3b*rGc+9NKiVl`HVt9PAX-XNm$%lGwyZ*;
zvPYnBxrlUN3j!KB(XhBd3NKh7{F%n<H~*y53Y${|?;_Rca{z~5TCT1~68KA_8o+@z
zSc-qu_>C*U+%55KlVgQpNtZeu{M-A#<}0F`8zym+DlT{{b>ld?yzC0Fl&ukUJXe@2
zDfyTy@nia-qF+`V)bpAXFq#mYV-z2m?#UjWP-n~C?|#1SUH1vP>fUwx-QLA`(5)uY
z1$R4n!EX&+Id(PA?*~r}F0HjO7h2Q1pJ{*7qdxV!$QAstrR$1XaCwsIZ1{MU-0X3r
zdDTRLKa!w!2yB?NQ111gQB6N1NnWjT{dlR7-Pv$ErgC{5?i(iYDfe#h#*CyXtk>4$
zMw%-$d^e01hl%-udbKcq;O$+t8>`<`m-+QI>dddYM!myMxvO8B4)>%aC?oYzv}=Da
zj%)5;*t359%a4|-xO>mI-StM9Ak_;F)BQv`d{OnT_QqcIt!>uW8Nu}j7lT2;b;d&h
zdu7nB4SsE$SYv5BMC0w&hpX1vemGZE@O7F=#!<;hObk=d7s~so{QxtY;_=_^vx2ma
zCul}A@;}n*gio|cVq!z*>kke9Y`=d^!YeC3u3r))v>YJ&5%MfrnGF394w`xLZKG#;
z{P(w4yCj>I?a-A7_mZCD`vv|E_PNP!WHo}q1e!iv(EtuwHc}(1(Q<)h&Eqwx?g6{s
zW%u<%@?!KqN3wbH{|sfX5M%QtA#Jx+0{inyS-I-rFSg1{75dSpSX7oL*KB`y6qbwb
z6D};&7C*<o1P3!7+QG}X;8*K(>05H3Yby7mP_8KU3A}5cPQP5A-BF#j=w|0p-fitW
z@bJLU9(Ojv>EHo}9ZuG@JXybe+^SU+3$%9bv4^~aN1g*Go^O2MsBZ}NJo~dVMZWG&
z8tjTZ->_JIO=NvRyYUVD_FI4YY}GmQF*a?Q$CVoyklvsNu8Vh6cULyUFv=}z?Naj2
z#}#+^E4Z!2b64@w`s`>I2kiadP>6Hc&e*H$=<s=_l%v`m<BXA#tjT-l9k!{<gqF3?
zt`RFYju0EET4}W|$$$Tk*Kdd;&*!$9bKc<ksm*y$yMtOYeZVXF)+>LkPYmekR{YHq
zeY;PV+S@_et!TzgWvs@W?V(;dVoH0U?zBOJu(+LOsE8vu#k(8p4>Bif#R>5vnK-wY
z!f|;|W5t8%bQv2vkjyiA<S*l3#`91+uATchde~O2iNH^%tFG|RQ^Z`(<o5TO&O;hX
zlb-n+4qz9{nb!_Z``v&31#B%xYd2S)s#u}m+0hNR`<af<?W8_G?dQJ}rRujOPC|CO
z^FGV>#f!>}beJqyy7XQK`fI0VNx>S;l^uPZTMt{$811GE3tlqfLCJ2Ig}f16$(>zO
z4ciLo)Q_jit>_WFyBS~;EHm6o4yREv=Gi6>Ln2nX)!nZNzIuNlJsgcjJFU5xLl$Wx
zf4oU!qG0_=W|W)%T%SL-!^!GovWj~WI(>msW5L&qg!3ymP%%yfnj!ygAwy{=vK_AN
zgMfNzRBgH~(NT<Xa&2(sKA?=e5{Xf~x*B$8BF?KU*I|x5PrlBTY^=HF*aDCn=W?S~
zxeDn>1+<Limyr)uvBJ`^GZPi5tk{c~{R6YKBN+k-w3<CyOm>VlsFT(uWdi64lh7k0
OlVBzg2K5U70001h9a5(N
delta 1679
zcmV;A25|ZJO!iE$*BJ@@V`N#zOykO@li(Rd729O@c563vsf%+}In23)G{CHd#A%Z`
z8XE%r{F7E1+W`lYG8;kxT$6Phive%50UQhg0g00i9i)F=zO+jPbotoX0yaqE(2S_!
zjFE4Qo&slXRSUH@vbvH-e>whe^%}K>vojEnQ3LKdP0qQ@84f27cbgi)VFmQ;kJXF{
z{(dCHUOX<CH+h$kyA=R+&x-shb?er-Utj}ZqJRNXJw7Lf!+D5iNV2Djr^r!WuH?Fz
z16k|ImO6it7#kZz*j%Hdx-G1cUIET`-;uj}@bWPK-M~2v!M$LLP3fPp^wJTX!X^t=
zEGK{%_Lw8H8qSfNxF3<uP7Q?$YRoE{+SbJw27bm7MV}%)rXUTT^h?aN<tI(#X;87t
zmQ-Yvs6+t5GrNr)Qc8xx!y(#d83DAbKi)c`%g=vPY{4*>!0vCp-|s8JtFgG$yTe{l
zX7k(eTG{@|_Fs#{XbBR8hpoUqJ(M7MXj_OG8V>Xy?G!PahOlH1EhVYTTWd;NRv}T@
zBT%?pL^`kq0gaq!Sll3m7c3C|Oyl*Nf6!@#%_)L+k!tigfWt2>SJxv6{H0M1;6NKJ
z#cF^2#+6|1miV^GvBI#VOPvn>?fqZ#717NNlekG07rd3aaU5M<b_H0<)`&WuE6kOY
ze9V>jG5uK4FDnk}dCdtJO$g30ijPe9WDifMv*qr0zg+jO`vhHe@4EeN?_xaYRuk!h
zyPdq?w}!49yPD_sgQo_U*4mg0t?At_wCR6QpZZ<o3jWyAbww?>JV|vne7s6-_BhhK
zYNEg&Nl-fkHcVP5_xjJMrk{}{uU5H!ywu3<Y`7g$xx5bd4U_nkdpCGvM$#14Yin{N
z%@rEH8%B%6#C$=$S{Og@_O9BE)o-fH{Q4So=2u;#-eITQ)vry5dr}gVk@_gwwHJTK
zHTN&<S-<}2M@v=Qy=UC+dZSE`>IH}Cej**dsCrj>W3T$wHf!vR;QE7$!Jyze<Dr1P
zGHBNZzcx;+v9ukc@pkLORqJd&oU1DMI?W{GsN^IjhAHR^<^9xtgqcn8`1|{;Ag$vG
znh}lskF+}B6D^XM*wFd<g98BDZ<BxU%F2)H*8~YI2grVeJd0K)LqCLrW}bZ8=$Rh>
z?d{br$);sHbS1*Qr04j4fxm-&Zn7I$ji4}rrVm#%fP<Ee)QD=dTwq!AculH%!0vb1
zef^NU82!(YY@Yl-L)k0D*nCMy+ijJ={=8CFu6p>Zt@2WZezGYRmF3Ab8y<g!<)Zt9
z3k$Wy&+#w8!HkD?@G>s=)jD1JmK^As%DpI*D~f#r@7kx+FV|;xRA()^*?E+ATl)??
zJTSD!osDohc)($YlXWdm)^8uTY8Ax-t(|-9A@AUk=fH{Q8y`688-hL0{_ISVulth*
zyCTmwES6srSzpj@d;`DzmOg)5b<TW@O`GO%<wgdiH|T-u;vLo9mCZ1Wa*JBKl)UqC
z#a;diZfo(}RlKx5JKDtod;d2S;#{^f_9{C%e4Z)gsCLIVW27W&^4@ueZR#?iWi7O8
z#LA5$#73%CTCGd+Km7gm8{)|Gxvl1$H@JRkbKcYLpw>(u@QS|m3hRFp1A4j@fAd7&
z?vthVc93=}nsHMZt1)MLs8^1d(jKTgZO|YrZl@V4;z&;M?#B9q%*k4DLi|W3&Ml^J
zT;9`I@nAY##>NgL^GqK3%Q%?vJk*YB=RS@ewpD8)@YCt4EBx~mF_$yB{e7nMkcQHv
zXTF95*u`?@wS&`sw|{>DTg%bf&DEzWRw#IObi?g_rsH!vsn1XQ`R_!j`p*(4A-mmq
zpXK}FMP)`hOcpF%dM^Y0wNtaCV2$R=j=s*VhplIfc2kB0FB$QmWH-!0-iWT`&aSD3
zZH08|$5Z82^a$SF46q578SW*A(<mA9Y?Fr}5i8y5?zaSAy^wz%jz*)M)?CaXi?oqH
z-lQ>6u>K@7%FVy8&mY_2WOXuG#XSj~zCfw5;A=+0`IQ@}7$*YFkbk$3p|lg(4%hZU
zK)p1oHr<x!D8@LsHn?&hP)1&f#3)`}4ZAZD=T(;LFvp%JU*}3T)?9OJ0mzMWxlyZJ
zg><9>TE_Cr$f^!lVd>bJiHcNK>_yD}0kgFu83GCYV`N#zOykO@lh-9>0_O>n(IX=k
ZP)h{{000000ssO4p8x;=^a}t0004mSVxIs2
diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/funcl-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/funcl-0.1.tm
index ccdc9d99..1d2fe64a 100644
--- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/funcl-0.1.tm
+++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/funcl-0.1.tm
@@ -64,16 +64,19 @@ namespace eval funcl {
set posn [lsearch $cmdlist _]
if {$posn <= 0} {
append body $cmdlist
- if {$i == [expr {[llength $args] -2}]} {
- #append body " \$data"
+ if {$i == ([llength $args]-2)} {
append body " $wrap"
}
+ #if {$i == [expr {[llength $args] -2}]} {
+ # #append body " \$data"
+ # append body " $wrap"
+ #}
if {$i > 0} {
set t {]}
}
} else {
append body [lrange $cmdlist 0 $posn-1]
- if {$i == [expr {[llength $args] -2}]} {
+ if {$i == ([llength $args] -2)} {
#append body " \$data"
append body " $wrap"
}
@@ -291,7 +294,7 @@ namespace eval funcl {
set posn [lsearch $cmdlist _]
if {$posn <= 0} {
append body $cmdlist
- if {$i == [expr {[llength $args] -1}]} {
+ if {$i == ([llength $args] -1)} {
append body " \$data"
}
if {$i > 0} {
@@ -299,7 +302,7 @@ namespace eval funcl {
}
} else {
append body [lrange $cmdlist 0 $posn-1]
- if {$i == [expr {[llength $args] -1}]} {
+ if {$i == ([llength $args] -1)} {
append body " \$data"
}
set t [lrange $cmdlist $posn+1 end]
diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/modpod-0.1.2.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/modpod-0.1.2.tm
index 166bd423..aa27ebce 100644
--- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/modpod-0.1.2.tm
+++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/modpod-0.1.2.tm
@@ -135,9 +135,10 @@ namespace eval modpod {
proc connect {args} {
puts stderr "modpod::connect--->>$args"
set argd [punk::args::get_dict {
+ @id -id ::modpod::connect
-type -default ""
- *values -min 1 -max 1
- path -type string -minlen 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)"
+ @values -min 1 -max 1
+ path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)"
} $args]
catch {
punk::lib::showdict $argd ;#heavy dependencies
@@ -329,14 +330,16 @@ namespace eval modpod::lib {
#zipfile is a pure zip at this point - ie no script/exe header
proc make_zip_modpod {args} {
set argd [punk::args::get_dict {
- -offsettype -default "archive" -choices {archive file} -help "Whether zip offsets are relative to start of file or start of zip-data within the file.
- 'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip,
- but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip)
- info-zip's 'zip -A' can sometimes convert archive-relative to file-relative.
- -offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'"
- *values -min 2 -max 2
- zipfile -type path -minlen 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries"
- outfile -type path -minlen 1 -help "path to output file. Name should be of the form packagename-version.tm"
+ @id -id ::modpod::lib::make_zip_modpod
+ -offsettype -default "archive" -choices {archive file} -help\
+ "Whether zip offsets are relative to start of file or start of zip-data within the file.
+ 'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip,
+ but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip)
+ info-zip's 'zip -A' can sometimes convert archive-relative to file-relative.
+ -offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'"
+ @values -min 2 -max 2
+ zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries"
+ outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm"
} $args]
set zipfile [dict get $argd values zipfile]
set outfile [dict get $argd values outfile]
diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm
index 08359461..738d89c5 100644
--- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm
+++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm
@@ -49,6 +49,17 @@ namespace eval punk {
}
set has_commandstack [expr {![catch {package require commandstack}]}]
+ if {$has_commandstack} {
+ if {[catch {
+ package require punk::packagepreference
+ } errM]} {
+ catch {puts stderr "Failed to load punk::packagepreference"}
+ }
+ catch punk::packagepreference::install
+ } else {
+ #
+ }
+
if {![interp issafe] && $has_commandstack && $::tcl_platform(platform) eq "windows"} {
#still a caching version of auto_execok - but with proper(fixed) search order
@@ -353,18 +364,12 @@ punk::aliascore::init
package require punk::repl::codethread
package require punk::config
#package require textblock
-package require punk::console
+package require punk::console ;#requires Thread
package require punk::ns
package require punk::winpath ;# for windows paths - but has functions that can be called on unix systems
package require punk::repo
package require punk::du
package require punk::mix::base
-if {[catch {
- package require punk::packagepreference
-} errM]} {
- puts stderr "Failed to load punk::packagepreference"
-}
-punk::packagepreference::install
namespace eval punk {
# -- --- ---
diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm
index 78a18304..37f8b712 100644
--- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm
+++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm
@@ -332,9 +332,11 @@ tcl::namespace::eval punk::args {
(used for trailing args that come after switches/opts)
%B%@argdisplay%N% ?opt val...?
options -header <str> (text for header row of table)
- -body <str> (text to replace entirety of autogenerated docs)
+ -body <str> (text to replace autogenerated arg info)
%B%@doc%N% ?opt val...?
options -name <str> -url <str>
+ %B%@seealso%N% ?opt val...?
+ options -name <str> -url <str> (for footer - unimplemented)
Some other options normally present on custom arguments are available
to use with the @leaders @opts @values directives to set defaults
@@ -842,7 +844,7 @@ tcl::namespace::eval punk::args {
#id An id will be allocated if no id line present or the -id value is "auto"
if {$DEF_definition_id ne ""} {
#disallow duplicate @id line
- error "punk::args::define - @id already set. Existing value $DEF_definition_id"
+ error "punk::args::define - @id already set. Existing value $DEF_definition_id\n[join $args \n]"
}
if {[dict exists $at_specs -id]} {
set DEF_definition_id [dict get $at_specs -id]
@@ -966,7 +968,7 @@ tcl::namespace::eval punk::args {
-anyopts {
set opt_any $v
}
- -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted {
+ -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted {
#review - only apply to certain types?
tcl::dict::set tmp_optspec_defaults $k $v
}
@@ -1012,7 +1014,7 @@ tcl::namespace::eval punk::args {
tcl::dict::set tmp_optspec_defaults $k $v
}
default {
- set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\
+ set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\
-nominsize -nomaxsize -norange -nochoices -nochoicelabels\
-type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\
-regexprepass -regexprefail -regexprefailmsg -validationtransform\
@@ -1050,7 +1052,7 @@ tcl::namespace::eval punk::args {
}
dict set F $fid LEADER_MAX $v
}
- -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase {
+ -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase {
#review - only apply to certain types?
tcl::dict::set tmp_leaderspec_defaults $k $v
}
@@ -1097,8 +1099,9 @@ tcl::namespace::eval punk::args {
}
default {
set known { -min -minvalues -max -maxvalues\
- -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\
- -nominsize -nomaxsize -norange -nochoices -nochoicelabels\
+ -minsize -maxsize -range\
+ -choices -choicegroups -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\
+ -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\
-type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\
-regexprepass -regexprefail -regexprefailmsg -validationtransform\
}
@@ -1135,7 +1138,7 @@ tcl::namespace::eval punk::args {
}
set val_max $v
}
- -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase {
+ -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase {
#review - only apply to certain types?
tcl::dict::set tmp_valspec_defaults $k $v
}
@@ -1182,7 +1185,9 @@ tcl::namespace::eval punk::args {
}
default {
set known { -min -minvalues -max -maxvalues\
- -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\
+ -minsize -maxsize -range\
+ -choices -choicegroups -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\
+ -nocase\
-nominsize -nomaxsize -norange -nochoices -nochoicelabels\
-type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\
-regexprepass -regexprefail -regexprefailmsg -validationtransform\
@@ -1195,6 +1200,10 @@ tcl::namespace::eval punk::args {
}
}
+ seealso {
+ #todo!
+ #like @doc, except displays in footer, multiple - sub-table?
+ }
default {
error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @argdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id"
}
@@ -1321,7 +1330,9 @@ tcl::namespace::eval punk::args {
}
}
}
- -default - -solo - -range - -choices - -choicegroups - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -minsize - -maxsize - -nocase - -optional - -multiple -
+ -default - -solo - -range -
+ -choices - -choicegroups - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -choiceinfo -
+ -minsize - -maxsize - -nocase - -optional - -multiple -
-validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE -
-regexprepass - -regexprefail - -regexprefailmsg
{
@@ -1528,80 +1539,181 @@ tcl::namespace::eval punk::args {
return $argdata_dict
}
- lappend PUNKARGS [list -dynamic 0 {
- @id -id ::punk::args::get_spec
- @cmd -name punk::args::get_definition -help\
- ""
- id -type string -help\
- "identifer for punk::args defintion
- This will usually be a fully-qualifed
- path for a command name"
- patternlist -type list -optional 1 -default * -help\
- "glob-style patterns for retrieving value or switch
- definitions. If ommitted or passed an empty string,
- the raw unresolved definition will be returned as
- a list, including possible leading flags such as
- -dynamic 0|1.
- If specified as * - the entire definition including
- directive lines will be returned in line form.
- (directives are lines beginning with
- @ e.g @id, @cmd etc)
- "
- override_dict -type dict -optional 1 -default "" -help\
- "unimplemented.
- Will allow overriding or adding flags to a returned
- definition line.
- "
- }]
- #rename get_definition ???
- proc get_spec {id args} {
- lassign $args patternlist override_dict
- if {[llength $args] > 2} {
- punk::args::get_by_id ::punk::args::get_spec [list $id {*}$args]
- return
+ #return raw definition list as created with 'define'
+ proc rawdef {id} {
+ variable argdefcache_by_id
+ set realid [real_id $id]
+ #return the raw definition - possibly with unresolved dynamic parts
+ if {![dict exists $argdefcache_by_id $realid]} {
+ return ""
}
- if {[llength $override_dict] % 2 != 0} {
- #malformed dict
- punk::args::get_by_id ::punk::args::get_spec [list $id {*}$args]
+ return [tcl::dict::get $argdefcache_by_id $realid]
+ }
+
+
+ namespace eval argdoc {
+ variable resolved_def_TYPE_CHOICES {* @id @cmd @leaders @opts @values @doc}
+
+ lappend PUNKARGS [list -dynamic 0 [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES] {
+ @id -id ::punk::args::resolved_def
+ @cmd -name punk::args::resolved_def -help\
+ ""
+ @leaders -min 0 -max 0
+ @opts
+ -form -default 0 -help\
+ "UNIMPLEMENTED
+ Ordinal index or name of command form"
+ -type -default * -choices {%TYPECHOICES%} -choiceprefix 0 -multiple 1
+ -override -type dict -optional 1 -default "" -help\
+ "dict of dicts. Key in outer dict is the name of a
+ directive or an argument. Inner dict is a map of
+ overrides/additions (-<flag> <newval>...) for that line.
+ (unimplemented).
+ "
+ @values -min 1 -max -1
+ id -type string -help\
+ "identifer for a punk::args definition
+ This will usually be a fully-qualifed
+ path for a command name"
+ pattern -type string -optional 1 -default * -multiple 1 -help\
+ "glob-style patterns for retrieving value or switch
+ definitions.
+
+ If -type is * and pattern is * the entire definition including
+ directive lines will be returned in line form.
+ (directives are lines beginning with
+ @ e.g @id, @cmd etc)
+
+ if -type is @leaders,@opts or @values matches from that type
+ will be returned.
+
+ if -type is another directive such as @id, @doc etc the
+ patterns are ignored.
+
+ "
+ }]]
+ }
+
+
+ proc resolved_def {args} {
+ set opts [dict create\
+ -type {}\
+ -form 0\
+ -override {}\
+ ]
+ if {[llength $args] < 1} {
+ #must have at least id
+ punk::args::get_by_id ::punk::args::resolved_def $args
return
}
+ set patterns [list]
+
+ #a definition id must not begin with "-"
+ for {set i 0} {$i < [llength $args]} {incr i} {
+ set a [lindex $args $i]
+ if {$a eq "-type"} {
+ incr i
+ dict lappend opts -type [lindex $args $i]
+ } elseif {[string match -* $a]} {
+ incr i
+ dict set opts $a [lindex $args $i]
+ } else {
+ set id [lindex $args $i]
+ set patterns [lrange $args $i+1 end]
+ break
+ }
+ if {$i == [llength $args]-1} {
+ punk::args::get_by_id ::punk::args::resolved_def $args
+ return
+ }
+ }
+ if {![llength $patterns]} {
+ set patterns [list *]
+ }
+ dict for {k v} $opts {
+ switch -- $k {
+ -form - -type - -override {}
+ default {
+ punk::args::get_by_id ::punk::args::resolved_def $args
+ return
+ }
+ }
+ }
+ set typelist [dict get $opts -type]
+ if {[llength $typelist] == 0} {
+ set typelist {*}
+ }
+ foreach type $typelist {
+ if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} {
+ punk::args::get_by_id ::punk::args::resolved_def $args
+ return
+ }
+ }
variable argdefcache_by_id
set realid [real_id $id]
+
if {$realid ne ""} {
- if {$patternlist eq ""} {
- #return the raw definition - possibly with unresolved dynamic parts
- return [tcl::dict::get $argdefcache_by_id $realid]
- } else {
- set deflist [tcl::dict::get $argdefcache_by_id $realid]
- set result ""
- set specdict [uplevel 1 [list ::punk::args::define {*}$deflist]]
- set arg_info [dict get $specdict ARG_INFO]
- foreach pat $patternlist {
- if {[string match $pat @id]} {
+ set deflist [tcl::dict::get $argdefcache_by_id $realid]
+ set result ""
+ set specdict [uplevel 1 [list ::punk::args::define {*}$deflist]]
+ set arg_info [dict get $specdict ARG_INFO]
+ set argtypes [dict create @opts option @leaders leader @values value]
+ foreach type $typelist {
+ switch -exact -- $type {
+ * {
+ append result \n "@id -id [dict get $specdict id]"
+ append result \n "@cmd [dict get $specdict cmd_info]"
+ append result \n "@doc [dict get $specdict doc_info]"
+ foreach tp {leader option value} {
+ foreach pat $patterns {
+ set matches [dict keys $arg_info $pat]
+ foreach m $matches {
+ set def [dict get $arg_info $m]
+ if {[dict get $def -ARGTYPE] eq $tp} {
+ set def [dict remove $def -ARGTYPE]
+ append result \n "$m $def"
+ }
+ }
+ }
+ }
+
+ }
+ @id {
#only a single id record can exist
append result \n "@id -id [dict get $specdict id]"
}
- if {[string match $pat @cmd]} {
+ @cmd {
#only a single @cmd record can exist
#merged if multiple in original def (?)
append result \n "@cmd [dict get $specdict cmd_info]"
}
- #todo @leaders, @opts, @values lines
- #can be multiple of each. We need to preserve order and interleave
- #with any matching arg_info results.
- #requires storing more info in the internal spec dictionary
- set matches [dict keys $arg_info $pat]
- foreach m $matches {
- set def [dict get $arg_info $m]
- set def [dict remove $def -ARGTYPE]
- append result \n "$m $def"
+ @doc {
+ #only a single @doc record can exist
+ append result \n "@doc [dict get $specdict doc_info]"
+ }
+ @leaders - @opts - @values {
+ #option,
+ foreach pat $patterns {
+ set matches [dict keys $arg_info $pat]
+ foreach m $matches {
+ set def [dict get $arg_info $m]
+ if {[dict get $def -ARGTYPE] eq [dict get $argtypes $type]} {
+ set def [dict remove $def -ARGTYPE]
+ append result \n "$m $def"
+ }
+ }
+ }
+ }
+ default {
}
}
- return $result
}
+
+ return $result
}
}
+
proc get_spec_values {id {patternlist *}} {
variable argdefcache_by_id
set realid [real_id $id]
@@ -1636,13 +1748,14 @@ tcl::namespace::eval punk::args {
#proc get_spec_opts ??
proc get_def {id} {
- if {[id_exists $id]} {
- return [define {*}[get_spec $id]]
- }
+ return [define {*}[rawdef $id]]
+ #if {[id_exists $id]} {
+ # return [define {*}[rawdef $id]]
+ #}
}
proc is_dynamic {id} {
- set spec [get_spec $id]
- return [expr {[lindex $spec 0] eq "-dynamic" && [lindex $spec 1]} ]
+ set deflist [rawdef $id]
+ return [expr {[lindex $deflist 0] eq "-dynamic" && [lindex $deflist 1]} ]
}
variable aliases
@@ -1661,6 +1774,8 @@ tcl::namespace::eval punk::args {
variable aliases
return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $argdefcache_by_id $match]]
}
+
+ #we don't automatically test for (autodef)$id - only direct ids and aliases
proc id_exists {id} {
variable argdefcache_by_id
variable aliases
@@ -1694,6 +1809,9 @@ tcl::namespace::eval punk::args {
return $id
} else {
if {![llength [update_definitions]]} {
+ if {[tcl::dict::exists $argdefcache_by_id (autodef)$id]} {
+ return (autodef)$id
+ }
return ""
} else {
if {[tcl::dict::exists $aliases $id]} {
@@ -1702,6 +1820,9 @@ tcl::namespace::eval punk::args {
if {[tcl::dict::exists $argdefcache_by_id $id]} {
return $id
}
+ if {[tcl::dict::exists $argdefcache_by_id (autodef)$id]} {
+ return (autodef)$id
+ }
return ""
}
}
@@ -1797,7 +1918,7 @@ tcl::namespace::eval punk::args {
@values -min 0 -max 0
}]
proc test_get_dict {args} {
- punk::args::get_dict {*}[punk::args::get_spec ::punk::args::test1] $args
+ punk::args::get_dict {*}[punk::args::rawdef ::punk::args::test1] $args
}
proc test_get_by_id {args} {
punk::args::get_by_id ::punk::args::test1 $args
@@ -2558,7 +2679,7 @@ tcl::namespace::eval punk::args {
mechanism and call this as necessary.
"
-return -default table -choices {string table tableobject}
- } {${[punk::args::get_spec ::punk::args::arg_error -scheme]}} {
+ } {${[punk::args::resolved_def -type @opts ::punk::args::arg_error -scheme]}} {
@values -min 0 -max 1
id -help\
@@ -2568,7 +2689,7 @@ tcl::namespace::eval punk::args {
proc usage {args} {
lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received
set id [dict get $values id]
- set definitionlist [get_spec $id]
+ set definitionlist [rawdef $id]
if {[llength $definitionlist] == 0} {
error "punk::args::usage - no such id: $id"
}
@@ -2589,7 +2710,7 @@ tcl::namespace::eval punk::args {
#deprecate?
proc get_by_id {id arglist} {
- set definitionlist [punk::args::get_spec $id]
+ set definitionlist [punk::args::rawdef $id]
if {[llength $definitionlist] == 0} {
error "punk::args::get_by_id - no such id: $id"
}
@@ -2633,6 +2754,25 @@ tcl::namespace::eval punk::args {
-errorstyle -type string -default enhanced -choices {enhanced standard minimal}
@values -min 3
sep -optional 0 -choices "--"
+
+
+ @form -form withid -synopsis "parse ?-form {int|<formname>...}? ?-errorstyle <choice>? -- withid $id"
+ withid -type literal -help\
+ "The literal value 'withid'"
+ id -type string -help\
+ "id of punk::args definition for a command"
+
+
+ @form -form withdef -synopsis "parse ?-form {int|<formname>...}? ?-errorstyle <choice>? -- withdef $def ?$def?"
+ withdef -type literal -help\
+ "The literal value 'withdef'"
+ def -type string -multiple 1 -optional 0 -help\
+ "Each remaining argument is a block of text
+ defining argument definitions.
+ As a special case, -dynamic <bool> may be
+ specified as the 1st 2 arguments. These are
+ not treated as an indicator to punk::args
+ about how to process the definition."
}]
proc parse {args} {
@@ -2669,7 +2809,8 @@ tcl::namespace::eval punk::args {
return "parse [llength $arglist] args withid $id, options:$opts"
}
withdef {
- if {[llength [lrange $args $split+3 end]] < 1} {
+ set deflist [lrange $args $split+3 end]
+ if {[llength $deflist] < 1} {
error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'"
}
return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts"
@@ -4173,7 +4314,7 @@ tcl::namespace::eval punk::args::lib {
# set PUNKARGS ""
#}
-lappend ::punk::args::register::NAMESPACES ::punk::args ::punk::args::lib
+lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm
index 353d1f65..1381af87 100644
--- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm
+++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm
@@ -890,7 +890,7 @@ namespace eval punk::lib {
set cur [lmap a_l $list_l { lindex $a_l 0 }]
set list_l [lmap a_l $list_l { lrange $a_l 1 end }]
- if {[join $cur {}] == {}} {
+ if {[join $cur {}] eq {}} {
break
}
lappend zip_l $cur
diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm
index d9d36291..7d59eb35 100644
--- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm
+++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm
@@ -687,50 +687,34 @@ namespace eval punk::mix::cli {
package require punk::zip
set zipfile $buildfolder/$basename-$module_build_version.zip ;#ordinary zip file (deflate)
- set zipmechanism "punk::zip" ;#todo - get choice of mechanism from config
+ #zipfs mkzip does exactly what we need anyway in this case
+ #unfortunately it's not available in all Tclsh versions we might be running..
+ if {[llength [info commands zipfs]]} {
+ #zipfs mkzip (2025) doesn't add entries for folders.
+ #(Therefore no timestamps)
+ #zip reading utils generally intuit their existence and display them - but often an editor can't add comments to them
+ set wd [pwd]
+ cd $buildfolder
+ puts "zipfs mkzip $zipfile #modpod-$basename-$module_build_version"
+ zipfs mkzip $zipfile #modpod-$basename-$module_build_version
+ cd $wd
- switch -- $zipmechanism {
- "punk::zip" {
- #use -base $buildfolder so that -directory is included in the archive - the modpod stub relies on this - and extraction would be potentially messy otherwise
- punk::zip::mkzip -base $buildfolder -directory $buildfolder/#modpod-$basename-$module_build_version -- $zipfile *
- }
- "zipfs" {
- if {[llength [info commands zipfs]]} {
- #'zipfs mkzip' does we need in this case
- #unfortunately it's not available in all Tclsh versions we might be running..
- #
- #sidenote:
- # as at 2024-10 - zipfs mkimg seems to create an apparently working zip - but on windows not updatable with 'zip -A' or 7z etc
- #This is because offsets are file relative vs archive relative
- #(pkzip & info-zip seem to prefer file-relative ie offsets that have been adjusted after cat headerfile zipfile > somekit
- #this isn't an issue for 'mkzip' here though as we don't yet have a headerfile so offset file vs archive are the same.
-
- set wd [pwd]
- cd $buildfolder
- puts "zipfs mkzip $zipfile #modpod-$basename-$module_build_version"
- zipfs mkzip $zipfile #modpod-$basename-$module_build_version
- cd $wd
- } else {
- #TODO - review punk::zip::mkzip and/or external zip to provide a fallback?
- set had_error 1
- lappend notes "zipfs_unavailable"
- puts stderr "WARNING: zipfs unavailable can't build $modulefile"
- }
- }
- default {
- set had_error 1
- lappend notes "unrecognized_zipmechanism"
- puts stderr "WARNING: no such zipmechanism '$zipmechanism' can't build $modulefile"
- }
- }
-
- if {[catch {package require modpod} errM]} {
- set had_error 1
- lappend notes "modpod_unavailable"
- puts stderr "WARNING: modpod package unavailable can't build $modulefile"
+ } else {
+ #use -base $buildfolder so that -directory is included in the archive - the modpod stub relies on this - and extraction would be potentially messy otherwise
+ #put in an archive-level comment to aid in debugging
+ #punk
+ punk::zip::mkzip -base $buildfolder -directory $buildfolder/#modpod-$basename-$module_build_version -- $zipfile *
+ #punk::zip::mkzip stores permissions - (unix style) - which zipfs mkzip doesn't
+ #Directory ident in zipfs relies on folders ending with trailing slash - if missing, it misidentifies dirs as files.
+ #(ie it can't use permissions/attributes alone to determine directory vs file)
+ #TODO - review punk::zip::mkzip and/or external zip to provide a fallback?
+ #JMN25
+
+ #set had_error 1
+ #lappend notes "zipfs_unavailable"
+ #puts stderr "WARNING: zipfs unavailable can't build $modulefile"
}
-
- if {!$had_error} {
+ if {!$had_error && [file exists $zipfiles]} {
package require modpod
modpod::lib::make_zip_modpod $zipfile $modulefile
}
diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm
index 6b1923b1..fa9e8d7c 100644
--- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm
+++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm
@@ -22,7 +22,7 @@ package require punk::path ;# for treefilenames, relative
package require punk::repo
package require punk::docgen ;#inline doctools - generate doctools .man files at src/docgen prior to using kettle to producing .html .md etc
package require punk::mix::cli ;#punk::mix::cli::lib used for kettle_call
-#package require punk::mix::util ;#for path_relative
+#package require punkcheck ;#for path_relative
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm
index 6235224a..8fa9ce89 100644
--- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm
+++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm
@@ -1995,7 +1995,7 @@ tcl::namespace::eval punk::ns {
-return -type string -default table -choices {string table tableobject}
- } {${[punk::args::get_spec ::punk::args::arg_error -scheme]}} {
+ } {${[punk::args::resolved_def -type @opts ::punk::args::arg_error -scheme]}} {
-- -type none -help\
"End of options marker
diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm
index 5f7dba71..03578a56 100644
--- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm
+++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm
@@ -119,6 +119,7 @@ tcl::namespace::eval punk::packagepreference {
#*** !doctools
#[call [fun install]]
#[para]Override ::package builtin (or the current implementation if it has already been renamed/overridden) to check for and prefer lowercase packages/modules
+ #[para](todo - check info loaded and restrict to existing version as determined from dll/so?)
#[para]The overriding package command will call whatever implementation was in place before install to do the actual work - once it has modified 'package require' names to lowercase.
#[para]This is intended to be in alignment with tip 590 "Recommend lowercase Package Names"
#[para] https://core.tcl-lang.org/tips/doc/trunk/tip/590.md
@@ -152,40 +153,83 @@ tcl::namespace::eval punk::packagepreference {
#despite preference for lowercase - we need to handle packages that insist on providing as uppercase
#(e.g we will still need to handle things like: package provide Tcl 8.6)
#Where the package is already provided uppercase we shouldn't waste time deferring to lowercase
+ set is_exact 0
if {[lindex $args 1] eq "-exact"} {
set pkg [lindex $args 2]
- set vwant [lindex $args 3]
- if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} {
- #although we could shortcircuit using vsatisfies to return the ver
- #we should instead pass through to COMMANDSTACKNEXT so as not to interfere with whatever it does.
- return [$COMMANDSTACKNEXT {*}$args]
-
- #if {$vwant eq "" || [$COMMANDSTACKNEXT vsatisfies $ver $vwant]} {
- # return $ver
- #} else {
- # #package already provided with a different version.. we will defer to underlying implementation to return the standard error
- # return [$COMMANDSTACKNEXT {*}$args]
- #}
- }
+ set vwant [lindex $args 3]-[lindex $args 3]
+ set is_exact 1
} else {
set pkg [lindex $args 1]
- set vwant [lindex $args 2]
- if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} {
- return [$COMMANDSTACKNEXT {*}$args]
- #if {$vwant eq "" || [$COMMANDSTACKNEXT vsatisfies $ver $vwant]} {
- # return $ver
- #}
+ set vwant [lrange $args 2 end] ;#rare - but version can be a list of options
+ if {[llength $vwant] == 1 && [string first - [lindex $vwant 0]] > 0} {
+ #only one version - and it has a dash
+ lassign [split [lindex $vwant 0] -] a b
+ if {$a eq $b} {
+ #string compare version nums (can contain dots and a|b)
+ set is_exact 1
+ }
+ }
+ }
+ if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} {
+ #although we could shortcircuit using vsatisfies to return the ver
+ #we should instead pass through to COMMANDSTACKNEXT so as not to interfere with whatever it does.
+ #e.g a package require logger further down the commandstack
+ return [$COMMANDSTACKNEXT {*}$args]
+ }
+
+ if {!$is_exact && [llength $vwant] <= 1 } {
+ #required version unspecified - or specified singularly
+ # ---------------------------------------------------------------
+ #An attempt to detect dll/so loaded and try to load same version
+ set pkgloadedinfo [lsearch -inline -index 1 [info loaded] $pkg]
+ if {![llength $pkgloadedinfo]} {
+ if {[regexp {[A-Z]} $pkg]} {
+ set pkgloadedinfo [lsearch -inline -index 1 [info loaded] [string tolower $pkg]]
+ if {![llength $pkgloadedinfo]} {
+ set pkgloadedinfo [lsearch -inline -index 1 [info loaded] [string totitle $pkg]]
+ }
+ }
+ }
+
+ if {[llength $pkgloadedinfo]} {
+ puts stderr "--> pkg not present but shared object seems to be loaded: $pkgloadedinfo"
+ lassign $pkgloadedinfo path name
+ set lcpath [string tolower $path]
+ set obj [file tail $lcpath]
+ if {[string match tcl9* $obj]} {
+ set obj [string range $obj 4 end]
+ } elseif {[string match lib* $obj]} {
+ set obj [string range $obj 3 end]
+ }
+ set pkginfo [file rootname $obj]
+ #e.g Thread2.8.8
+ if {[regexp {^([a-zA-Z\-]+)(.*)} $pkginfo _match lname lversion]} {
+ if {[string tolower $lname] eq [string tolower $pkg]} {
+ #name matches pkg
+ #hack for known dll version mismatch
+ if {[string tolower $pkg] eq "thread" && $lversion eq "30b3"} {
+ set lversion 3.0b3
+ }
+ if {[llength $vwant] == 1} {
+ #todo - still check vsatisfies - report a conflict? review
+ }
+ return [$COMMANDSTACKNEXT require $pkg $lversion-$lversion]
+ }
+ }
}
}
+ # ---------------------------------------------------------------
+ set pkgloadedinfo [lsearch -inline -index 1 [info loaded] $pkg]
+
if {[regexp {[A-Z]} $pkg]} {
#only apply catch & retry if there was a cap - otherwise we'll double try for errors unrelated to capitalisation
- if {[catch {$COMMANDSTACKNEXT {*}[string tolower $args]} v]} {
- return [$COMMANDSTACKNEXT {*}$args]
+ if {[catch {$COMMANDSTACKNEXT require [string tolower $pkg] {*}$vwant} v]} {
+ return [$COMMANDSTACKNEXT require $pkg {*}$vwant]
} else {
return $v
}
} else {
- return [$COMMANDSTACKNEXT {*}$args]
+ return [$COMMANDSTACKNEXT require $pkg {*}$vwant]
}
}
default {
diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm
index b3693f71..6158fdce 100644
--- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm
+++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm
@@ -137,6 +137,13 @@ tcl::namespace::eval punk::repl::codethread {
variable run_command_cache
+ #Use interp exists instead..
+ #if {[catch {interp children}]} {
+ # #8.6.10 doesn't have it.. when was it introduced?
+ #} else {
+
+ #}
+
proc is_running {} {
variable running
return $running
@@ -150,7 +157,7 @@ tcl::namespace::eval punk::repl::codethread {
#expecting to be called from a thread::send in parent repl - ie in the toplevel interp so that the sub-interp "code" is available
#if a thread::send is done from the commandline in a codethread - Tcl will
- if {"code" ni [interp children] || ![info exists replthread_cond]} {
+ if {![interp exists code] || ![info exists replthread_cond]} {
#in case someone tries calling from codethread directly - don't do anything or change any state
#(direct caller could create an interp named code at the level "" -> "code" -"code" and add a replthread_cond value to avoid this check - but it probably won't do anything useful)
#if called directly - the context will be within the first 'code' interp.
diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm
index 11ae9ab2..2895b024 100644
--- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm
+++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm
@@ -179,26 +179,55 @@ tcl::namespace::eval punk::zip {
# punk::zip::walk -exclude {CVS/* *~.#*} library
#}]
+ #todo: -relative 0|1 flag?
set argd [punk::args::get_dict {
@id -id ::punk::zip::walk
- @cmd -name punk::zip::walk
+ @cmd -name punk::zip::walk -help\
+ "Walk the directory structure starting at base/<-subpath>
+ and return a list of the files and folders encountered.
+ Resulting paths are relative to base unless -resultrelative
+ is supplied.
+ Folder names will end with a trailing slash.
+ "
+ -resultrelative -optional 1 -help\
+ "Resulting paths are relative to this value.
+ Defaults to the value of base. If empty string
+ is given to -resultrelative the paths returned
+ are effectively absolute paths."
-excludes -default "" -help "list of glob expressions to match against files and exclude"
- -subpath -default ""
+ -subpath -default "" -help\
+ "May contain glob chars for folder elements"
@values -min 1 -max -1
base
fileglobs -default {*} -multiple 1
} $args]
set base [dict get $argd values base]
- set fileglobs [dict get $argd values fileglobs]
+ set fileglobs [dict get $argd values fileglobs]
set subpath [dict get $argd opts -subpath]
set excludes [dict get $argd opts -excludes]
+ set received [dict get $argd received]
set imatch [list]
foreach fg $fileglobs {
lappend imatch [file join $subpath $fg]
}
+ if {![dict exists $received -resultrelative]} {
+ set relto $base
+ set prefix ""
+ } else {
+ set relto [file normalize [dict get $argd opts -resultrelative]]
+ if {$relto ne ""} {
+ if {![Path_a_atorbelow_b $base $relto]} {
+ error "punk::zip::walk base must be at or below -resultrelative value (backtracking not currently supported)"
+ }
+ set prefix [Path_strip_alreadynormalized_prefixdepth $base $relto]
+ } else {
+ set prefix $base
+ }
+ }
+
set result {}
#set imatch [file join $subpath $match]
set files [glob -nocomplain -tails -types f -directory $base -- {*}$imatch]
@@ -210,7 +239,7 @@ tcl::namespace::eval punk::zip {
break
}
}
- if {!$excluded} {lappend result $file}
+ if {!$excluded} {lappend result [file join $prefix $file]}
}
foreach dir [glob -nocomplain -tails -types d -directory $base -- [file join $subpath *]] {
set subdir_entries [walk -subpath $dir -excludes $excludes $base {*}$fileglobs]
@@ -218,7 +247,7 @@ tcl::namespace::eval punk::zip {
#NOTE: trailing slash required for entries to be recognised as 'file type' = "directory"
#This is true for 2024 Tcl9 mounted zipfs at least. zip utilities such as 7zip seem(icon correct) to recognize dirs with or without trailing slash
#Although there are attributes on some systems to specify if entry is a directory - it appears trailing slash should always be used for folder names.
- set result [list {*}$result "$dir/" {*}$subdir_entries]
+ set result [list {*}$result "[file join $prefix $dir]/" {*}$subdir_entries]
}
}
return $result
@@ -554,7 +583,9 @@ tcl::namespace::eval punk::zip {
-comment -default ""\
-help "An optional comment for the archive"
-directory -default ""\
- -help "The new zip archive will scan for contents within this folder or current directory if not provided."
+ -help "The new zip archive will scan for contents within this folder or current directory if not provided.
+ Note that this will
+ "
-base -default ""\
-help "The new zip archive will be rooted in this directory if provided
it must be a parent of -directory or the same path as -directory"
@@ -605,6 +636,7 @@ tcl::namespace::eval punk::zip {
set base $opts(-directory)
set relpath ""
}
+ #will pick up intermediary folders as paths (ending with trailing slash)
set paths [walk -exclude $opts(-exclude) -subpath $relpath -- $base {*}[dict get $argd values globs]]
set norm_filename [file normalize $filename]
@@ -654,6 +686,8 @@ tcl::namespace::eval punk::zip {
}
}
} else {
+ #NOTE that we don't add intermediate folders when creating an archive without using the -directory flag!
+ #ie - only the exact *files* matching the glob are stored.
set paths [list]
set dir [pwd]
if {$opts(-base) ne ""} {
@@ -712,7 +746,7 @@ tcl::namespace::eval punk::zip {
if {$opts(-offsettype) eq "archive"} {
set dataStartOffset [tell $zf] ;#the overall file offset of the start of archive-data //JMN 2024
} else {
- set dataStartOffset 0 ;#offsets relative to file - the zipfs mkzip way :/
+ set dataStartOffset 0 ;#offsets relative to file - the (old) zipfs mkzip way :/
}
set count 0
diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm
index 32450e55..56651d21 100644
--- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm
+++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm
@@ -96,42 +96,60 @@ tcl::namespace::eval textblock {
variable use_hash ;#framecache
set use_hash none ;#slightly faster but uglier layout for viewing frame_cache display
- #if {![catch {package require sha1}]} {
- # set use_hash sha1
- #} elseif {![catch {package require md5}]} {
- # set use_hash md5
- #} else {
- # set use_hash none
- #}
- proc use_hash {args} {
- set choices [list none]
- set unavailable [list]
- set pkgs [package names]
- if {"md5" in $pkgs} {
- lappend choices md5
- } else {
- lappend unavailable md5
+ namespace eval argdoc {
+ proc hash_algorithm_choices_and_help {} {
+ set choices [list none]
+ set unavailable [list]
+ set unloaded [dict create]
+ set algorithm_packages {md5 sha1 sha256}
+ foreach p $algorithm_packages {
+ if {[package provide $p] eq ""} {
+ dict set unloaded $p ""
+ }
+ }
+ if {[dict size $unloaded]} {
+ set allpkgs [package names] ;#only retrieve once
+ foreach p $algorithm_packages {
+ if {[dict exists $unloaded $p]} {
+ #not loaded - but check if available
+ if {$p in $allpkgs} {
+ lappend choices $p
+ } else {
+ lappend unavailable $p
+ }
+ } else {
+ lappend choices $p
+ }
+ }
+ } else {
+ lappend choices {*}$algorithm_packages
+ set unavailable ""
+ }
+
+ set choicemsg ""
+ if {[llength $unavailable]} {
+ set choicemsg " (unavailable packages: $unavailable)"
+ }
+ #return $choices
+ return " -choices \{$choices\} -help {algorithm choice $choicemsg} "
}
- if {"sha1" in $pkgs} {
- lappend choices sha1
- } else {
- lappend unavailable sha1
- }
- set choicemsg ""
- if {[llength $unavailable]} {
- set choicemsg " (unavailable packages: $unavailable)"
- }
- set argd [punk::args::get_dict [tstr -return string {
- @id -id ::textblock::use_hash
- @cmd -name "textblock::use_hash" -help\
- "Hashing algorithm to use for framecache lookup.
- 'none' may be slightly faster but less compact
- when viewing textblock::framecache"
- @values -min 0 -max 1
- hash_algorithm -choices {${$choices}} -optional 1 -help\
- "algorithm choice ${$choicemsg}"
- }] $args]
+ }
+
+ # hash_algorithm -optional 1 -choices {${[::textblock::argdoc::hash_algorithm_choices]}} -help\
+ # "algorithm choice"
+
+ punk::args::define -dynamic 1 {
+ @id -id ::textblock::use_hash
+ @cmd -name "textblock::use_hash" -help\
+ "Hashing algorithm to use for framecache lookup.
+ 'none' may be slightly faster but less compact
+ when viewing textblock::framecache"
+ @values -min 0 -max 1
+ hash_algorithm -optional 1 ${[::textblock::argdoc::hash_algorithm_choices_and_help]}
+ }
+ proc use_hash {args} {
+ set argd [punk::args::get_by_id ::textblock::use_hash $args]
variable use_hash
if {![dict exists $argd received hash_algorithm]} {
return $use_hash
@@ -4367,6 +4385,15 @@ tcl::namespace::eval textblock {
"
-return -default table -choices {table tableobject}
+ -table -default "" -type string\
+ -help "existing table object to use"
+ -action -default "append" -choices {append replace}\
+ -help "row insertion method if existing -table is supplied
+ if append is chosen the new values will always start at the first column"
+ -title -type string -help\
+ "Title to display overlayed on top edge of table.
+ Will not be visible if -show_edge is false"
+ -titlealign -type string -choices {left centre right}
-frametype -default "light" -type dict -choices {${$FRAMETYPES}} -choicerestricted 0\
-help "frame type or dict for custom frame"
-show_edge -default "" -type boolean\
@@ -4377,10 +4404,21 @@ tcl::namespace::eval textblock {
-show_hseps -default "" -type boolean\
-help "Show horizontal table separators
(default 0 if no existing -table supplied)"
- -table -default "" -type string\
- -help "existing table object to use"
-colheaders -default "" -type list\
- -help "list of lists. list of column header values. Outer list must match number of columns"
+ -help {list of lists. list of column header values. Outer list must match number of columns.
+ A table
+ e.g single header row: -colheaders {{column_a} {column_b} {column_c}}
+ e.g 2 header rows: -colheaders {{column_a "nextrow test"} {column_b} {column_c}}
+ Note that each element of the outer list is itself a list so:
+ -colheaders {"column a" "column b" "column c"}
+ Is likely not the right format if it was intended to have a single header row where the
+ column titles contain spaces.
+ The correct syntax for that would be:
+ -colheaders {{"column a"} {"column b"} {"column c"}}
+ For spanning header cells - use 'set t [list_as_table -return tableobject ...]'
+ and then something like:
+ $t configure_header 1 -colspans {3 0 0}; $t print
+ }
-header -default "" -type list -multiple 1\
-help "Each supplied -header argument is a header row.
The number of values for each must be <= number of columns"
@@ -4388,9 +4426,6 @@ tcl::namespace::eval textblock {
-help "Whether to show a header row.
Omit for unspecified/automatic,
in which case it will display only if -headers list was supplied."
- -action -default "append" -choices {append replace}\
- -help "row insertion method if existing -table is supplied
- if append is chosen the new values will always start at the first column"
-columns -default "" -type integer\
-help "Number of table columns
Will default to 2 if not using an existing -table object"
@@ -4404,6 +4439,7 @@ tcl::namespace::eval textblock {
set argd [punk::args::get_by_id ::textblock::list_as_table $args]
set opts [dict get $argd opts]
+ set received [dict get $argd received]
set datalist [dict get $argd values datalist]
set existing_table [dict get $opts -table]
@@ -4560,6 +4596,12 @@ tcl::namespace::eval textblock {
}
$t add_row $row
}
+ if {"-title" in $received} {
+ $t configure -title [dict get $opts -title]
+ }
+ if {"-titlealign" in $received} {
+ $t configure -titlealign [dict get $opts -titlealign]
+ }
#puts stdout $rowdata
if {[tcl::dict::get $opts -return] eq "table"} {
set result [$t print]
@@ -5895,7 +5937,16 @@ tcl::namespace::eval textblock {
append out [textblock::join -- $punks $cpunks] \n
set 2frames_a [textblock::join -- [textblock::frame -checkargs 0 $cpunks] [textblock::frame -checkargs 0 $punks]]
append out $2frames_a \n
- set 2frames_b [textblock::join -- [textblock::frame -checkargs 0 -ansiborder $cyanb -title "plainpunks" $punks] [textblock::frame -checkargs 0 -ansiborder $greenb -title "fancypunks" $cpunks]]
+ set 2frames_b [textblock::join --\
+ [textblock::frame -checkargs 0 -ansiborder $cyanb\
+ -title "plainpunks" $punks]\
+ [textblock::frame -checkargs 0 -ansiborder $greenb\
+ -title "fancy"\
+ -titlealign right\
+ -subtitle "punks"\
+ -subtitlealign left\
+ $cpunks]\
+ ]
append out [textblock::frame -checkargs 0 -title "punks" $2frames_b\n$RST$2frames_a] \n
set punkdeck [overtype::right [overtype::left [textblock::frame -checkargs 0 -ansiborder [a+ green bold] -type heavy -title ${redb}PATTERN$RST -subtitle ${redb}PUNK$RST $prightair_cyanb] "$blueb\n\n\P\nU\nN\nK$RST"] "$blueb\n\nD\nE\nC\nK"]
set spantable [[spantest] print]
@@ -7503,20 +7554,41 @@ tcl::namespace::eval textblock {
@id -id ::textblock::frame_cache
@cmd -name textblock::frame_cache -help\
"Display or clear the frame cache."
- -action -default {} -choices {clear} -help\
- "Clear the textblock::frame_cache dictionary"
-pretty -default 1 -help\
- "Use 'pdict textblock::frame_cache */*' for prettier output"
- @values -min 0 -max 0
+ "Uses 'pdict textblock::frame_cache */*' for prettier output
+ Either way this is set, output requires long lines and may
+ still wrap in an ugly manner. Try 'textblock::use_cache md5'
+ to shorten the argument display and reduce wrapping.
+ "
+ @values -min 0 -max 1
+ action -default {display} -choices {clear size info display} -choicelabels {
+ clear "Clear the textblock::frame_cache dictionary."
+ } -help "Perform an action on the frame cache."
}
proc frame_cache {args} {
set argd [punk::args::get_by_id ::textblock::frame_cache $args]
- set action [dict get $argd opts -action]
-
- if {$action ni [list clear ""]} {
- error "frame_cache action '$action' not understood. Valid actions: clear"
- }
+ set action [dict get $argd values action]
variable frame_cache
+ switch -- $action {
+ clear {
+ set size [dict size $frame_cache]
+ set frame_cache [tcl::dict::create]
+ return "frame_cache cleared $size entries"
+ }
+ size {
+ return [dict size $frame_cache]
+ }
+ info {
+ return [dict info $frame_cache]
+ }
+ display {
+ #fall through
+ }
+ default {
+ #assert - unreachable - punk::args should have validated
+ error "frame_cache -action '$action' not understood. Valid actions: clear size info display"
+ }
+ }
if {[dict get $argd opts -pretty]} {
set out [pdict -chan none frame_cache */*]
} else {
@@ -7544,10 +7616,6 @@ tcl::namespace::eval textblock {
append out \n ;# frames used to build tables often have joins - keep a line in between for clarity
}
}
- if {$action eq "clear"} {
- set frame_cache [tcl::dict::create]
- append out \nCLEARED
- }
return $out
}
@@ -7608,9 +7676,11 @@ tcl::namespace::eval textblock {
May contain ANSI - no trailing reset required.
${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing
e.g 2: frame -title [a+ red underline]MyThing${[textblock::RST]}"
+ -titlealign -default "centre" -choices {left centre right}
-subtitle -default "" -type string -regexprefail {\n}\
-help "Frame subtitle placed on bottombar - no newlines
May contain Ansi - no trailing reset required."
+ -subtitlealign -default "centre" -choices {left centre right}
-width -default "" -type int\
-help "Width of resulting frame including borders.
If omitted or empty-string, the width will be determined automatically based on content."
@@ -7667,7 +7737,9 @@ tcl::namespace::eval textblock {
-boxmap {}\
-joins [list]\
-title ""\
+ -titlealign "centre"\
-subtitle ""\
+ -subtitlealign "centre"\
-width ""\
-height ""\
-ansiborder ""\
@@ -7710,7 +7782,7 @@ tcl::namespace::eval textblock {
set k2 [tcl::prefix::match -error "" $optnames $k]
switch -- $k2 {
-etabs - -type - -boxlimits - -boxmap - -joins
- - -title - -subtitle - -width - -height
+ - -title - -titlealign - -subtitle - -subtitlealign - -width - -height
- -ansiborder - -ansibase
- -blockalign - -textalign - -ellipsis
- -crm_mode
@@ -7879,6 +7951,10 @@ tcl::namespace::eval textblock {
package require sha1
set hash [sha1::sha1 [encoding convertto utf-8 $hashables]]
}
+ sha256 {
+ package require sha256
+ set hash [sha2::sha256 [encoding convertto utf-8 $hashables]]
+ }
md5 {
package require md5
if {[package vsatisfies [package present md5] 2- ] } {
@@ -7887,7 +7963,7 @@ tcl::namespace::eval textblock {
set hash [md5::md5 [encoding convertto utf-8 $hashables]]
}
}
- none {
+ default {
set hash $hashables
}
}
@@ -8246,12 +8322,24 @@ tcl::namespace::eval textblock {
}
if {$opt_title ne ""} {
- set topbar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $tbar $opt_title] ;#overtype supports gx0 on/off
+ set titlealign [dict get $opts -titlealign]
+ set titlealignfull [tcl::prefix::match -error "" {left centre right} $titlealign]
+ if {$titlealignfull ni {left centre right}} {
+ error "textblock::frame -titlealign must be one of {left centre right} or a unique prefix thereof. Received $titlealign"
+ }
+ #set topbar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $tbar $opt_title] ;#overtype supports gx0 on/off
+ set topbar [overtype::block -blockalign $titlealignfull -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 $tbar $opt_title] ;#overtype supports gx0 on/off
} else {
set topbar $tbar
}
if {$opt_subtitle ne ""} {
- set bottombar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $bbar $opt_subtitle] ;#overtype supports gx0 on/off
+ set titlealign [dict get $opts -subtitlealign]
+ set titlealignfull [tcl::prefix::match -error "" {left centre right} $titlealign]
+ if {$titlealignfull ni {left centre right}} {
+ error "textblock::frame -subtitlealign must be one of {left centre right} or a unique prefix thereof. Received $titlealign"
+ }
+ #set bottombar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $bbar $opt_subtitle] ;#overtype supports gx0 on/off
+ set bottombar [overtype::block -blockalign $titlealignfull -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 $bbar $opt_subtitle] ;#overtype supports gx0 on/off
} else {
set bottombar $bbar
}
diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/zipper-0.12.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/zipper-0.12.tm
index 6bf5e87eacb2aef2c5a678ce61f5af937be974d7..080e7da9391e33c62e5e9c49bd5c3006ae2e5f48 100644
GIT binary patch
delta 1668
zcmV-~27CGTO!rK%*BJ@4nmt-fc8oQsli(Rd6}x2jc563vsf%+}In23)G{CHd#A=f{
z8XE%t^pjQ^+W~u%G8;kxRFicZivh2*0UQhg0g;mq9i)HMZ+5AGE+0Evzy?Vinh{l;
zG4hSkQ{c?4YN7T<R#)=qFUKFQUZb{fb_U`xYQR0G$vKxf!{Nl?Zc`&Ttbm^Vv6@lA
z-;adYi^m1?Chrn*w*sK<S&=`bZrwWf3v2*P6fi)l$LGXwI1kYbN%mCn6gkSvm0UM-
zAZtC@QYU{BV`GB|n`?Abw}my*E5P~gJ92jqULNMZ8#sp{xED;ZDg85+UOJ*v*kr+q
z<pdDJ9&=<?!#R=@_aoBTsi9Cojafxg+qxLTz|T0M=u@P}6r{nEeu<g3{G^FI4Jvlo
zl8THHl?cF>FX6enJEW8hg@;45&oTmNSAV>9M3;Y`r`UpFE`i<Oe81mUgjZv6sdtCH
zqRi&E<F&H=lkLA2iO~`y2oGC<eR?QC^3b*rGc+9NKiVl`HVt9PAX-XNm$%lGwyZ*;
zvPYnBxrlUN3j!KB(XhBd3NKh7{F%n<H~*y53Y${|?;_Rca{z~5TCT1~68KA_8o+@z
zSc-qu_>C*U+%55KlVgQpNtZeu{M-A#<}0F`8zym+DlT{{b>ld?yzC0Fl&ukUJXe@2
zDfyTy@nia-qF+`V)bpAXFq#mYV-z2m?#UjWP-n~C?|#1SUH1vP>fUwx-QLA`(5)uY
z1$R4n!EX&+Id(PA?*~r}F0HjO7h2Q1pJ{*7qdxV!$QAstrR$1XaCwsIZ1{MU-0X3r
zdDTRLKa!w!2yB?NQ111gQB6N1NnWjT{dlR7-Pv$ErgC{5?i(iYDfe#h#*CyXtk>4$
zMw%-$d^e01hl%-udbKcq;O$+t8>`<`m-+QI>dddYM!myMxvO8B4)>%aC?oYzv}=Da
zj%)5;*t359%a4|-xO>mI-StM9Ak_;F)BQv`d{OnT_QqcIt!>uW8Nu}j7lT2;b;d&h
zdu7nB4SsE$SYv5BMC0w&hpX1vemGZE@O7F=#!<;hObk=d7s~so{QxtY;_=_^vx2ma
zCul}A@;}n*gio|cVq!z*>kke9Y`=d^!YeC3u3r))v>YJ&5%MfrnGF394w`xLZKG#;
z{P(w4yCj>I?a-A7_mZCD`vv|E_PNP!WHo}q1e!iv(EtuwHc}(1(Q<)h&Eqwx?g6{s
zW%u<%@?!KqN3wbH{|sfX5M%QtA#Jx+0{inyS-I-rFSg1{75dSpSX7oL*KB`y6qbwb
z6D};&7C*<o1P3!7+QG}X;8*K(>05H3Yby7mP_8KU3A}5cPQP5A-BF#j=w|0p-fitW
z@bJLU9(Ojv>EHo}9ZuG@JXybe+^SU+3$%9bv4^~aN1g*Go^O2MsBZ}NJo~dVMZWG&
z8tjTZ->_JIO=NvRyYUVD_FI4YY}GmQF*a?Q$CVoyklvsNu8Vh6cULyUFv=}z?Naj2
z#}#+^E4Z!2b64@w`s`>I2kiadP>6Hc&e*H$=<s=_l%v`m<BXA#tjT-l9k!{<gqF3?
zt`RFYju0EET4}W|$$$Tk*Kdd;&*!$9bKc<ksm*y$yMtOYeZVXF)+>LkPYmekR{YHq
zeY;PV+S@_et!TzgWvs@W?V(;dVoH0U?zBOJu(+LOsE8vu#k(8p4>Bif#R>5vnK-wY
z!f|;|W5t8%bQv2vkjyiA<S*l3#`91+uATchde~O2iNH^%tFG|RQ^Z`(<o5TO&O;hX
zlb-n+4qz9{nb!_Z``v&31#B%xYd2S)s#u}m+0hNR`<af<?W8_G?dQJ}rRujOPC|CO
z^FGV>#f!>}beJqyy7XQK`fI0VNx>S;l^uPZTMt{$811GE3tlqfLCJ2Ig}f16$(>zO
z4ciLo)Q_jit>_WFyBS~;EHm6o4yREv=Gi6>Ln2nX)!nZNzIuNlJsgcjJFU5xLl$Wx
zf4oU!qG0_=W|W)%T%SL-!^!GovWj~WI(>msW5L&qg!3ymP%%yfnj!ygAwy{=vK_AN
zgMfNzRBgH~(NT<Xa&2(sKA?=e5{Xf~x*B$8BF?KU*I|x5PrlBTY^=HF*aDCn=W?S~
zxeDn>1+<Limyr)uvBJ`^GZPi5tk{c~{R6YKBN+k-w3<CyOm>VlsFT(uWdi64lh7k0
OlVBzg2K5U70001h9a5(N
delta 1679
zcmV;A25|ZJO!iE$*BJ@@V`N#zOykO@li(Rd729O@c563vsf%+}In23)G{CHd#A%Z`
z8XE%r{F7E1+W`lYG8;kxT$6Phive%50UQhg0g00i9i)F=zO+jPbotoX0yaqE(2S_!
zjFE4Qo&slXRSUH@vbvH-e>whe^%}K>vojEnQ3LKdP0qQ@84f27cbgi)VFmQ;kJXF{
z{(dCHUOX<CH+h$kyA=R+&x-shb?er-Utj}ZqJRNXJw7Lf!+D5iNV2Djr^r!WuH?Fz
z16k|ImO6it7#kZz*j%Hdx-G1cUIET`-;uj}@bWPK-M~2v!M$LLP3fPp^wJTX!X^t=
zEGK{%_Lw8H8qSfNxF3<uP7Q?$YRoE{+SbJw27bm7MV}%)rXUTT^h?aN<tI(#X;87t
zmQ-Yvs6+t5GrNr)Qc8xx!y(#d83DAbKi)c`%g=vPY{4*>!0vCp-|s8JtFgG$yTe{l
zX7k(eTG{@|_Fs#{XbBR8hpoUqJ(M7MXj_OG8V>Xy?G!PahOlH1EhVYTTWd;NRv}T@
zBT%?pL^`kq0gaq!Sll3m7c3C|Oyl*Nf6!@#%_)L+k!tigfWt2>SJxv6{H0M1;6NKJ
z#cF^2#+6|1miV^GvBI#VOPvn>?fqZ#717NNlekG07rd3aaU5M<b_H0<)`&WuE6kOY
ze9V>jG5uK4FDnk}dCdtJO$g30ijPe9WDifMv*qr0zg+jO`vhHe@4EeN?_xaYRuk!h
zyPdq?w}!49yPD_sgQo_U*4mg0t?At_wCR6QpZZ<o3jWyAbww?>JV|vne7s6-_BhhK
zYNEg&Nl-fkHcVP5_xjJMrk{}{uU5H!ywu3<Y`7g$xx5bd4U_nkdpCGvM$#14Yin{N
z%@rEH8%B%6#C$=$S{Og@_O9BE)o-fH{Q4So=2u;#-eITQ)vry5dr}gVk@_gwwHJTK
zHTN&<S-<}2M@v=Qy=UC+dZSE`>IH}Cej**dsCrj>W3T$wHf!vR;QE7$!Jyze<Dr1P
zGHBNZzcx;+v9ukc@pkLORqJd&oU1DMI?W{GsN^IjhAHR^<^9xtgqcn8`1|{;Ag$vG
znh}lskF+}B6D^XM*wFd<g98BDZ<BxU%F2)H*8~YI2grVeJd0K)LqCLrW}bZ8=$Rh>
z?d{br$);sHbS1*Qr04j4fxm-&Zn7I$ji4}rrVm#%fP<Ee)QD=dTwq!AculH%!0vb1
zef^NU82!(YY@Yl-L)k0D*nCMy+ijJ={=8CFu6p>Zt@2WZezGYRmF3Ab8y<g!<)Zt9
z3k$Wy&+#w8!HkD?@G>s=)jD1JmK^As%DpI*D~f#r@7kx+FV|;xRA()^*?E+ATl)??
zJTSD!osDohc)($YlXWdm)^8uTY8Ax-t(|-9A@AUk=fH{Q8y`688-hL0{_ISVulth*
zyCTmwES6srSzpj@d;`DzmOg)5b<TW@O`GO%<wgdiH|T-u;vLo9mCZ1Wa*JBKl)UqC
z#a;diZfo(}RlKx5JKDtod;d2S;#{^f_9{C%e4Z)gsCLIVW27W&^4@ueZR#?iWi7O8
z#LA5$#73%CTCGd+Km7gm8{)|Gxvl1$H@JRkbKcYLpw>(u@QS|m3hRFp1A4j@fAd7&
z?vthVc93=}nsHMZt1)MLs8^1d(jKTgZO|YrZl@V4;z&;M?#B9q%*k4DLi|W3&Ml^J
zT;9`I@nAY##>NgL^GqK3%Q%?vJk*YB=RS@ewpD8)@YCt4EBx~mF_$yB{e7nMkcQHv
zXTF95*u`?@wS&`sw|{>DTg%bf&DEzWRw#IObi?g_rsH!vsn1XQ`R_!j`p*(4A-mmq
zpXK}FMP)`hOcpF%dM^Y0wNtaCV2$R=j=s*VhplIfc2kB0FB$QmWH-!0-iWT`&aSD3
zZH08|$5Z82^a$SF46q578SW*A(<mA9Y?Fr}5i8y5?zaSAy^wz%jz*)M)?CaXi?oqH
z-lQ>6u>K@7%FVy8&mY_2WOXuG#XSj~zCfw5;A=+0`IQ@}7$*YFkbk$3p|lg(4%hZU
zK)p1oHr<x!D8@LsHn?&hP)1&f#3)`}4ZAZD=T(;LFvp%JU*}3T)?9OJ0mzMWxlyZJ
zg><9>TE_Cr$f^!lVd>bJiHcNK>_yD}0kgFu83GCYV`N#zOykO@lh-9>0_O>n(IX=k
ZP)h{{000000ssO4p8x;=^a}t0004mSVxIs2
diff --git a/src/vendormodules/modpod-0.1.2.tm b/src/vendormodules/modpod-0.1.2.tm
index 166bd423..aa27ebce 100644
--- a/src/vendormodules/modpod-0.1.2.tm
+++ b/src/vendormodules/modpod-0.1.2.tm
@@ -135,9 +135,10 @@ namespace eval modpod {
proc connect {args} {
puts stderr "modpod::connect--->>$args"
set argd [punk::args::get_dict {
+ @id -id ::modpod::connect
-type -default ""
- *values -min 1 -max 1
- path -type string -minlen 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)"
+ @values -min 1 -max 1
+ path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)"
} $args]
catch {
punk::lib::showdict $argd ;#heavy dependencies
@@ -329,14 +330,16 @@ namespace eval modpod::lib {
#zipfile is a pure zip at this point - ie no script/exe header
proc make_zip_modpod {args} {
set argd [punk::args::get_dict {
- -offsettype -default "archive" -choices {archive file} -help "Whether zip offsets are relative to start of file or start of zip-data within the file.
- 'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip,
- but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip)
- info-zip's 'zip -A' can sometimes convert archive-relative to file-relative.
- -offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'"
- *values -min 2 -max 2
- zipfile -type path -minlen 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries"
- outfile -type path -minlen 1 -help "path to output file. Name should be of the form packagename-version.tm"
+ @id -id ::modpod::lib::make_zip_modpod
+ -offsettype -default "archive" -choices {archive file} -help\
+ "Whether zip offsets are relative to start of file or start of zip-data within the file.
+ 'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip,
+ but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip)
+ info-zip's 'zip -A' can sometimes convert archive-relative to file-relative.
+ -offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'"
+ @values -min 2 -max 2
+ zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries"
+ outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm"
} $args]
set zipfile [dict get $argd values zipfile]
set outfile [dict get $argd values outfile]
diff --git a/src/vendormodules/packagetrace-0.8.tm b/src/vendormodules/packagetrace-0.8.tm
index 6798eb8d..2025cdc2 100644
--- a/src/vendormodules/packagetrace-0.8.tm
+++ b/src/vendormodules/packagetrace-0.8.tm
@@ -318,7 +318,7 @@ set packagetrace::showpresent 0 to skip <present/> output
#normalize
if {$is_exact} {
set req [lindex $v_requirements 0] ;#only one is allowed for -exact
- set v_requirement $req-$req ;#translate to v-v normalised equiv of -exact
+ set v_requirements $req-$req ;#translate to v-v normalised equiv of -exact
} else {
set reqs [list]
foreach req $v_requirements {
diff --git a/src/vendormodules/packagetrace-0.9.tm b/src/vendormodules/packagetrace-0.9.tm
new file mode 100644
index 00000000..59697f78
--- /dev/null
+++ b/src/vendormodules/packagetrace-0.9.tm
@@ -0,0 +1,643 @@
+
+
+#JMN 2005 - Public Domain
+#
+#REVIEW: This package may not robustly output xml. More testing & development required.
+#
+
+#NOTE: the 'x' attribute on the 'info' tag may have its value truncated.
+#It is a human-readable indicator only and should not be used to cross-reference to the corresponding 'require' tag using the 'p' attribute.
+#Use the fact that the corresponding 'info' tag directly follows its 'require' tag.
+
+
+#changes
+#2021-09-17
+# - added variable ::packagetrace::showpresent with default 1
+# setting this to 0 will hide the <present/> tags which sometimes make the output too verbose.
+# - changed t from an integer number of milliseconds to show fractional millis by using ([clock microseconds]-$t0)/1000.0 in the expr.
+
+namespace eval packagetrace::class {
+ if {[info commands [namespace current]::tracer] eq ""} {
+ oo::class create tracer {
+ method get {} {
+ }
+ method test {} {
+ return tracertest
+ }
+ }
+ }
+}
+
+
+namespace eval packagetrace {
+ variable tracerlist [list]
+ variable chan stderr
+ variable showpresent 1
+ variable output ""
+
+
+ proc help {} {
+ return {
+ REVIEW - documentation inaccurate
+Enable package tracing using 'package require packagetrace'
+Disable package tracing using 'package forget packagetrace; package require packagetrace'
+ (This 2nd 'package require packagetrace' will raise an error. This is deliberate.)
+use packagetrace::channel <chan> to desired output channel or none. (default stderr)
+
+set packagetrace::showpresent 0 to skip <present/> output
+}
+ }
+
+ # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == ==
+ # Maintenance - tm_version... functions - primary source is punk::lib module
+ # - these should be synced with code from latest punk::lib
+ # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == ==
+ proc tm_version_isvalid {versionpart} {
+ #Needs to be suitable for use with Tcl's 'package vcompare'
+ if {![catch [list package vcompare $versionpart $versionpart]]} {
+ return 1
+ } else {
+ return 0
+ }
+ }
+ proc tm_version_major {version} {
+ if {![tm_version_isvalid $version]} {
+ error "Invalid version '$version' is not a proper Tcl module version number"
+ }
+ set firstpart [lindex [split $version .] 0]
+ #check for a/b in first segment
+ if {[string is integer -strict $firstpart]} {
+ return $firstpart
+ }
+ if {[string first a $firstpart] > 0} {
+ return [lindex [split $firstpart a] 0]
+ }
+ if {[string first b $firstpart] > 0} {
+ return [lindex [split $firstpart b] 0]
+ }
+ error "tm_version_major unable to determine major version from version number '$version'"
+ }
+ proc tm_version_canonical {ver} {
+ #accepts a single valid version only - not a bounded or unbounded spec
+ if {![tm_version_isvalid $ver]} {
+ error "tm_version_canonical version '$ver' is not valid for a package version"
+ }
+ set parts [split $ver .]
+ set newparts [list]
+ foreach o $parts {
+ set trimmed [string trimleft $o 0]
+ set firstnonzero [string index $trimmed 0]
+ switch -exact -- $firstnonzero {
+ "" {
+ lappend newparts 0
+ }
+ a - b {
+ #e.g 000bnnnn -> bnnnnn
+ set tailtrimmed [string trimleft [string range $trimmed 1 end] 0]
+ if {$tailtrimmed eq ""} {
+ set tailtrimmed 0
+ }
+ lappend newparts 0$firstnonzero$tailtrimmed
+ }
+ default {
+ #digit
+ if {[string is integer -strict $trimmed]} {
+ #e.g 0100 -> 100
+ lappend newparts $trimmed
+ } else {
+ #e.g 0100b003 -> 100b003 (still need to process tail)
+ if {[set apos [string first a $trimmed]] > 0} {
+ set lhs [string range $trimmed 0 $apos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch
+ set rhs [string range $trimmed $apos+1 end] ;#assert rhs non-empty and only digits
+ set rhs [string trimleft $rhs 0]
+ if {$rhs eq ""} {
+ set rhs 0
+ }
+ lappend newparts ${lhs}a${rhs}
+ } elseif {[set bpos [string first b $trimmed]] > 0} {
+ set lhs [string range $trimmed 0 $bpos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch
+ set rhs [string range $trimmed $bpos+1 end] ;#assert rhs non-empty and only digits
+ set rhs [string trimleft $rhs 0]
+ if {$rhs eq ""} {
+ set rhs 0
+ }
+ lappend newparts ${lhs}b${rhs}
+ } else {
+ #assert - shouldn't get here trimmed val should have been empty, an int or contained an a or b
+ error "tm_version_canonical error - trimfail - unexpected"
+ }
+ }
+ }
+ }
+ }
+ return [join $newparts .]
+ }
+ proc tm_version_required_canonical {versionspec} {
+ #also trim leading zero from any dottedpart?
+ #Tcl *allows* leading zeros in any of the dotted parts - but they are not significant.
+ #e.g 1.01 is equivalent to 1.1 and 01.001
+ #also 1b3 == 1b0003
+
+ if {[string trim $versionspec] eq ""} {return ""} ;#unspecified = any version
+ set errmsg "tm_version_required_canonical - invalid version specification"
+ if {[string first - $versionspec] < 0} {
+ #no dash
+ #looks like a minbounded version (ie a single version with no dash) convert to min-max form
+ set from $versionspec
+ if {![tm_version_isvalid $from]} {
+ error "$errmsg '$versionpec'"
+ }
+ if {![catch {tm_version_major $from} majorv]} {
+ set from [tm_version_canonical $from]
+ return "${from}-[expr {$majorv +1}]"
+ } else {
+ error "$errmsg '$versionspec'"
+ }
+ } else {
+ # min- or min-max
+ #validation and canonicalisation (strip leading zeroes from each segment, including either side of a or b)
+ set parts [split $versionspec -] ;#we expect only 2 parts
+ lassign $parts from to
+ if {![tm_version_isvalid $from]} {
+ error "$errmsg '$versionspec'"
+ }
+ set from [tm_version_canonical $from]
+ if {[llength $parts] == 2} {
+ if {$to ne ""} {
+ if {![tm_version_isvalid $to]} {
+ error "$errmsg '$versionspec'"
+ }
+ set to [tm_version_canonical $to]
+ return $from-$to
+ } else {
+ return $from-
+ }
+ } else {
+ error "$errmsg '$versionspec'"
+ }
+ error "tm_version_required_canonical should have already returned a canonicalised versionspec - or produced an error with reason before this point"
+ }
+ }
+ # end tm_version... functions
+ # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == ==
+
+ #convenience function in case the sequence 'package forget packagetrace;package require packagetrace' is too unintuitive or weird.
+ #REVIEW
+ proc unload {} {
+ package forget packagetrace
+ if {[catch {package require packagetrace}]} {
+ return 1 ;#yes - we get an error if we unloaded successfully
+ } else {
+ error "packagetrace was not unloaded"
+ }
+ }
+ proc emit {str} {
+ variable chan
+ variable output
+ append output $str
+ if {$chan ne "none"} {
+ puts -nonewline $chan $str
+ }
+ return
+ }
+ proc get {{as raw}} {
+ variable output
+ switch -- [string tolower $as] {
+ asxml {
+ if {[package provide tdom] eq ""} {
+ set previous_output $output
+ package require tdom
+ set output $previous_output
+ }
+ set d [dom parse $output]
+ return [$d asXML]
+ }
+ aslist {
+ if {[package provide tdom] eq ""} {
+ set previous_output $output
+ package require tdom
+ set output $previous_output
+ }
+ set d [dom parse $output]
+ return [$d asList]
+ }
+ default {
+ return $output
+ }
+ }
+ }
+ proc channel {{ch ""}} {
+ variable chan
+ switch -exact -- $ch {
+ "" {
+ return $chan
+ }
+ none {
+ set chan none
+ return none
+ }
+ stderr - stdout {
+ #note stderr stdout not necessarily in [chan names] (due to transforms etc?) but can still work
+ set chan $ch
+ return $ch
+ }
+ default {
+ if {$ch in [chan names]} {
+ set chan $ch
+ return $ch
+ } else {
+ error "chan '$ch' not in \[chan names\]: [chan names]"
+ }
+ }
+ }
+ }
+ proc init {} {
+ uplevel 1 {
+ set ::packagetrace::level -1
+ if {![llength [info commands tcl_findLibrary]]} {
+ tcl::namespace::eval :: $::auto_index(tcl_findLibrary)
+ }
+ package require commandstack
+
+
+ set targetcommand [namespace which tcl_findLibrary] ;# normalize to presumably ::tcl_findLibrary
+ set stackrecord [commandstack::rename_command -renamer packagetrace $targetcommand [info args $targetcommand] {
+ set marg [string repeat { } $::packagetrace::level]
+ packagetrace::emit "${marg}<extra> tcl_findLibrary $basename $version $patch $initScript $enVarName $varName </extra>\n"
+ uplevel 1 [list $COMMANDSTACKNEXT $basename $version $patch $initScript $enVarName $varName]
+ }]
+ if {[dict get $stackrecord implementation] ne ""} {
+ set old_tcl_findLibrary [dict get $stackrecord implementation]
+ puts stderr "packagetrace::init renamed $targetcommand to $old_tcl_findLibrary and is providing an override"
+ } else {
+ puts stderr "packagetrace::init failed to rename $targetcommand"
+ }
+
+
+
+ set package_command [namespace which package]
+ set stackrecord [commandstack::rename_command -renamer packagetrace $package_command {subcommand args} {
+ set tracerlist $::packagetrace::tracerlist
+ set tracer [lindex $tracerlist end]
+ if {$tracer eq ""} {
+
+ }
+ set ch $::packagetrace::chan
+ set next $COMMANDSTACKNEXT
+ if {$next ne "$COMMANDSTACKNEXT_ORIGINAL"} {
+ puts stderr "(packagetrace package) DEBUG - command changed since start: $COMMANDSTACKNEXT_ORIGINAL is now $next"
+ }
+
+ #cache $ch instead of using upvar,
+ #because namespace may be deleted during call.
+
+ #!todo - optionally silence Tcl & Tk requires to reduce output?
+ #if {[lindex $args 0] eq "Tcl"} {
+ # return [$next $subcommand {*}$args]
+ #}
+ switch -exact -- [tcl::prefix::match {files forget ifneeded names prefer present provide require unknown vcompare versions vsatisfies} $subcommand] {
+ require {
+ #columns
+ set c1 [string repeat { } 30] ;#tree col
+ set c1a " "
+ set c2 [string repeat { } 20] ;#package name col
+ set c2a " " ;# close require/present tags
+ set c3 [string repeat { } 18] ;#version col - must handle v= "999999.0a1.0" without truncation
+ set c4 [string repeat { } 12] ;#timing col 5 chars of punct leaving remainder for value.
+ set c5 [string repeat { } 10] ;#module col
+ set c5a [string repeat { } 3] ;#close result tag col
+
+ #we assume 'package require' API sticks to solo option flags like -exact and is relatively stable.
+ set argidx 0
+ set is_exact 0
+ foreach a $args {
+ if {[string range $a 0 0] ne "-"} {
+ #assume 1st non-dashed argument is package name
+ set pkg $a
+ set v_requirements [lrange $args $argidx+1 end]
+ #normalize
+ if {$is_exact} {
+ set req [lindex $v_requirements 0] ;#only one is allowed for -exact
+ set v_requirements $req-$req ;#translate to v-v normalised equiv of -exact
+ } else {
+ set reqs [list]
+ foreach req $v_requirements {
+ lappend reqs [::packagetrace::tm_version_required_canonical $req] ;#empty remains empty, v -> v-<majorv+1>, leading zeros stripped from all segments.
+ }
+ set v_requirements $reqs ;#each normalised
+ }
+ set pkg_ [lrange $args $argidx end] ;# raw e.g "Tcl 8.6" or "Tcl 8.5 9"
+ break
+ } else {
+ if {$a eq "-exact"} {
+ set is_exact 1
+ }
+ }
+ incr argidx
+ }
+
+
+ incr ::packagetrace::level
+ if {$::packagetrace::level == 0} {
+ set packagetrace::output ""
+ }
+
+
+ set marg [string repeat { } $::packagetrace::level]
+ set margnext [string repeat { } [expr {$::packagetrace::level + 1}]]
+
+ if {![catch {set ver [$next present {*}$args]}]} {
+ if {$::packagetrace::showpresent} {
+ #already loaded..
+ set f1 [packagetrace::overtype::left $c1 "${marg}<present"]
+ set f2 [packagetrace::overtype::left -overflow 1 $c2 "p= \"$pkg_\""] ;#disallow truncation!
+ set f2a $c2a
+ set f3 [packagetrace::overtype::left $c3 "v= \"$ver\""]
+ set f4 $c4
+ set f5 $c5
+ set f5a "/> "
+ #puts -nonewline $ch $f1$c1a$f2$f2a$f3$f4$f5\n
+ packagetrace::emit $f1$c1a$f2$f2a$f3$f4$f5$f5a\n
+ }
+ } else {
+ set f1 [packagetrace::overtype::left $c1 "${marg}<require"]
+ set f2 [packagetrace::overtype::left -overflow 1 $c2 "p= \"$pkg_\""] ;#disallow truncation!
+ set f2a $c2a
+ set f3 $c3
+ set f4 $c4
+ set f5 $c5
+ set f5a " > "
+ #puts -nonewline $ch $f1$c1a$f2$f2a$f3$f4$f5\n
+ packagetrace::emit $f1$c1a$f2$f2a$f3$f4$f5$f5a\n
+
+ set errMsg ""
+ #set t0 [clock clicks -milliseconds]
+ set t0 [clock microseconds]
+
+ if {[catch {set ver [$next require {*}$args]} errMsg]} {
+ set ver ""
+ #
+ #NOTE error must be raised at some point - see below
+ }
+ #set t [expr {[clock clicks -millisec]-$t0}]
+ set t [expr {([clock microseconds]-$t0)/1000.0}]
+
+
+
+
+ #jmn
+ set f1 [packagetrace::overtype::left $c1 "${margnext}<info "]
+ #set f1a "<info "
+ set f1a ""
+
+ set f2 [packagetrace::overtype::left -ellipsis 1 [string range $c2 0 end-1] "x= \"$args"]
+ if {[string length [string trimright $f2]] <= [expr [string length $c2]-1]} {
+ #right-trimmed value shorter than field.. therefore we need to close attribute
+ set f2 [packagetrace::overtype::left $c2 [string trimright $f2]\"]
+ }
+
+ #we use the attributename x because this is not necessarily the same as p! may be truncated.
+
+ set f3 [packagetrace::overtype::left $c3 "v= \"$ver\""]
+
+ #truncate time to c4 width - possibly losing some precision. If truncated - add closing double quote.
+ set f4 [packagetrace::overtype::left -overflow 1 $c4 "t= \"[lrange $t 0 1]\""]
+ if {[string length [string trimright $f4]] > [expr {[string length $c4]}]} {
+ set f4 "[packagetrace::overtype::left [string range $c4 0 end-1] [string trimright $f4]]\""
+ }
+
+ if {[string length $ver]} {
+ set num ""
+ foreach c [split $ver ""] {
+ if {[string is digit $c] || $c eq "."} {
+ append num $c
+ } else {
+ break
+ }
+ }
+ set ver $num
+
+ #review - scr not guaranteed to be valid tcl list - should parse properly?
+ set scr [$next ifneeded $pkg $ver]
+ if {[string range $scr end-2 end] ne ".tm"} {
+ set f5 $c5
+ } else {
+ #!todo - optionally output module path instead of boolean?
+ #set f5 [packagetrace::overtype::left -ellipsis 1 -ellipsistext ... [string range $c5 0 end-1] "tm= \"[lindex $scr end]"]
+ set f5 [packagetrace::overtype::left -ellipsis 1 -ellipsistext ... [string range $c5 0 end-1] "tm= \"1"]
+ if {[string length [string trimright $f5]] <= [expr [string length $c5]-1]} {
+ set f5 [packagetrace::overtype::left $c5 [string trimright $f5]\"]
+ }
+ }
+ } else {
+ set f5 $c5
+ }
+
+ set f5a [packagetrace::overtype::left $c5a "/>"] ;#end of <info
+ #puts -nonewline $ch "$f1$c1a$f2$c2a$f3$f4 $f5$f5a\n"
+ packagetrace::emit "$f1$c1a$f2$c2a$f3$f4 $f5$f5a\n"
+
+
+ set f1 [packagetrace::overtype::left $c1 "${marg}</require>"]
+ set f1a ""
+ set f2 ""
+ set c2a ""
+ set f3 ""
+ set f4 ""
+ set f5 ""
+ set f5a ""
+ #puts -nonewline $ch $f1$f1a$f2$c2a$f3$f4$f5$f5a\n
+ packagetrace::emit $f1$f1a$f2$c2a$f3$f4$f5$f5a\n
+
+
+ if {![string length $ver]} {
+ if {[lindex $args 0] eq "packagetrace"} {
+ #REVIEW - what is going on here?
+ namespace delete ::packagetrace::overtype
+ }
+
+ #we must raise an error if original 'package require' would have
+ incr ::packagetrace::level -1
+ error $errMsg
+ }
+
+ }
+ incr ::packagetrace::level -1
+ return $ver
+ }
+ vcompare - vsatisifies - provide - ifneeded {
+ set result [$next $subcommand {*}$args]
+ #puts -nonewline $ch " -- package $subcommand $args\n"
+ return $result
+ }
+ default {
+ set result [$next $subcommand {*}$args]
+ #puts $ch "*** here $subcommand $args"
+ return $result
+ }
+ }
+
+ }]
+ if {[set stored_target [dict get $stackrecord implementation]] ne ""} {
+ puts stderr "packagetrace::init renamed $package_command to $stored_target and is providing an override"
+ set f1 [string repeat { } 30]
+ #set f1a " "
+ set f1a ""
+ set f2 [packagetrace::overtype::left [string repeat { } 20] "PACKAGE"]
+ set f2a " "
+ set f3 [packagetrace::overtype::left [string repeat { } 15] "VERSION"]
+ set f4 [packagetrace::overtype::left [string repeat { } 12] "LOAD-ms"]
+ set f5 [packagetrace::overtype::left [string repeat { } 10] "MODULE"]
+
+ #puts -nonewline $::packagetrace::chan "-$f1$f1a$f2$f2a$f3$f4$f5\n"
+ #packagetrace::emit "-$f1$f1a$f2$f2a$f3$f4$f5\n"
+ puts -nonewline stderr "-$f1$f1a$f2$f2a$f3$f4$f5\n"
+ unset f1 f1a f2 f2a f3 f4 f5
+ } else {
+ puts stderr "packagetrace::init failed to rename $package_command"
+ }
+ }
+ }
+}
+
+
+
+#The preferred source of the ::overtype::<direction> functions is the 'overtype' package
+# - pasted here because packagetrace should have no extra dependencies.
+# - overtype package has better support for ansi and supports wide chars
+namespace eval packagetrace::overtype {set version INLINE}
+
+namespace eval packagetrace::overtype {
+ proc left {args} {
+ # @c overtype starting at left (overstrike)
+ # @c can/should we use something like this?: 'format "%-*s" $len $overtext
+
+ if {[llength $args] < 2} {
+ error {usage: ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext}
+ }
+ foreach {undertext overtext} [lrange $args end-1 end] break
+
+ set opt(-ellipsis) 0
+ set opt(-ellipsistext) {...}
+ set opt(-overflow) 0
+ array set opt [lrange $args 0 end-2]
+
+
+ set len [string length $undertext]
+ set overlen [string length $overtext]
+ set diff [expr {$overlen - $len}]
+ if {$diff > 0} {
+ if {$opt(-overflow)} {
+ return $overtext
+ } else {
+ if {$opt(-ellipsis)} {
+ return [right [string range $overtext 0 [expr {$len -1}]] $opt(-ellipsistext)]
+ } else {
+ return [string range $overtext 0 [expr {$len -1}]]
+ }
+ }
+ } else {
+
+ return "$overtext[string range $undertext $overlen end]"
+ }
+ }
+
+ proc centre {args} {
+ if {[llength $args] < 2} {
+ error {usage: ?-bias [left|right]? ?-overflow [1|0]? undertext overtext}
+ }
+ foreach {undertext overtext} [lrange $args end-1 end] break
+
+ set opt(-bias) left
+ set opt(-overflow) 0
+ array set opt [lrange $args 0 end-2]
+
+
+ set olen [string length $overtext]
+ set ulen [string length $undertext]
+ set diff [expr {$ulen - $olen}]
+ if {$diff > 0} {
+ set half [expr {round(int($diff / 2))}]
+ if {[string match right $opt(-bias)]} {
+ if {[expr {2 * $half}] < $diff} {
+ incr half
+ }
+ }
+
+ set rhs [expr {$diff - $half - 1}]
+ set lhs [expr {$half - 1}]
+
+ set a [string range $undertext 0 $lhs]
+ set b $overtext
+ set c [string range $undertext end-$rhs end]
+ return $a$b$c
+ } else {
+ if {$diff < 0} {
+ if {$opt(-overflow)} {
+ return $overtext
+ } else {
+ return [string range $overtext 0 [expr {$ulen - 1}]]
+ }
+ } else {
+ return $overtext
+ }
+ }
+ }
+
+ proc right {args} {
+ if {[llength $args] < 2} {
+ error {usage: ?-overflow [1|0]? undertext overtext}
+ }
+ lassign [lrange $args end-1 end] undertext overtext
+
+ set opt(-overflow) 0
+ array set opt [lrange $args 0 end-2]
+
+ set olen [string length $overtext]
+ set ulen [string length $undertext]
+
+ if {$opt(-overflow)} {
+ return [string range $undertext 0 end-$olen]$overtext
+ } else {
+ if {$olen > $ulen} {
+ set diff [expr {$olen - $ulen}]
+ return [string range $undertext 0 end-$olen][string range $overtext 0 end-$diff]
+ } else {
+ return [string range $undertext 0 end-$olen]$overtext
+ }
+ }
+ }
+
+}
+
+
+
+
+
+proc packagetrace::deinit {} {
+ packagetrace::disable
+ #namespace delete packagetrace
+ #package forget packagetrace
+}
+proc packagetrace::disable {} {
+ ::commandstack::remove_rename {::tcl_findLibrary packagetrace}
+ ::commandstack::remove_rename {::package packagetrace}
+}
+proc packagetrace::enable {} {
+ #init doesn't clear state - so this is effectively an alias
+ tailcall packagetrace::init
+}
+
+#clear state - reset to defaults
+proc packagetrace::clear {} {
+ variable chan
+ set chan stderr
+ variable showpresent
+ set showpresent 1
+}
+
+package provide packagetrace [namespace eval packagetrace {
+ set version 0.9
+}]
+
+
diff --git a/src/vfs/_vfscommon.vfs/modules/funcl-0.1.tm b/src/vfs/_vfscommon.vfs/modules/funcl-0.1.tm
index ccdc9d99..1d2fe64a 100644
--- a/src/vfs/_vfscommon.vfs/modules/funcl-0.1.tm
+++ b/src/vfs/_vfscommon.vfs/modules/funcl-0.1.tm
@@ -64,16 +64,19 @@ namespace eval funcl {
set posn [lsearch $cmdlist _]
if {$posn <= 0} {
append body $cmdlist
- if {$i == [expr {[llength $args] -2}]} {
- #append body " \$data"
+ if {$i == ([llength $args]-2)} {
append body " $wrap"
}
+ #if {$i == [expr {[llength $args] -2}]} {
+ # #append body " \$data"
+ # append body " $wrap"
+ #}
if {$i > 0} {
set t {]}
}
} else {
append body [lrange $cmdlist 0 $posn-1]
- if {$i == [expr {[llength $args] -2}]} {
+ if {$i == ([llength $args] -2)} {
#append body " \$data"
append body " $wrap"
}
@@ -291,7 +294,7 @@ namespace eval funcl {
set posn [lsearch $cmdlist _]
if {$posn <= 0} {
append body $cmdlist
- if {$i == [expr {[llength $args] -1}]} {
+ if {$i == ([llength $args] -1)} {
append body " \$data"
}
if {$i > 0} {
@@ -299,7 +302,7 @@ namespace eval funcl {
}
} else {
append body [lrange $cmdlist 0 $posn-1]
- if {$i == [expr {[llength $args] -1}]} {
+ if {$i == ([llength $args] -1)} {
append body " \$data"
}
set t [lrange $cmdlist $posn+1 end]
diff --git a/src/vfs/_vfscommon.vfs/modules/modpod-0.1.2.tm b/src/vfs/_vfscommon.vfs/modules/modpod-0.1.2.tm
index 166bd423..aa27ebce 100644
--- a/src/vfs/_vfscommon.vfs/modules/modpod-0.1.2.tm
+++ b/src/vfs/_vfscommon.vfs/modules/modpod-0.1.2.tm
@@ -135,9 +135,10 @@ namespace eval modpod {
proc connect {args} {
puts stderr "modpod::connect--->>$args"
set argd [punk::args::get_dict {
+ @id -id ::modpod::connect
-type -default ""
- *values -min 1 -max 1
- path -type string -minlen 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)"
+ @values -min 1 -max 1
+ path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)"
} $args]
catch {
punk::lib::showdict $argd ;#heavy dependencies
@@ -329,14 +330,16 @@ namespace eval modpod::lib {
#zipfile is a pure zip at this point - ie no script/exe header
proc make_zip_modpod {args} {
set argd [punk::args::get_dict {
- -offsettype -default "archive" -choices {archive file} -help "Whether zip offsets are relative to start of file or start of zip-data within the file.
- 'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip,
- but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip)
- info-zip's 'zip -A' can sometimes convert archive-relative to file-relative.
- -offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'"
- *values -min 2 -max 2
- zipfile -type path -minlen 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries"
- outfile -type path -minlen 1 -help "path to output file. Name should be of the form packagename-version.tm"
+ @id -id ::modpod::lib::make_zip_modpod
+ -offsettype -default "archive" -choices {archive file} -help\
+ "Whether zip offsets are relative to start of file or start of zip-data within the file.
+ 'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip,
+ but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip)
+ info-zip's 'zip -A' can sometimes convert archive-relative to file-relative.
+ -offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'"
+ @values -min 2 -max 2
+ zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries"
+ outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm"
} $args]
set zipfile [dict get $argd values zipfile]
set outfile [dict get $argd values outfile]
diff --git a/src/vfs/_vfscommon.vfs/modules/packagetrace-0.8.tm b/src/vfs/_vfscommon.vfs/modules/packagetrace-0.8.tm
index 6798eb8d..2025cdc2 100644
--- a/src/vfs/_vfscommon.vfs/modules/packagetrace-0.8.tm
+++ b/src/vfs/_vfscommon.vfs/modules/packagetrace-0.8.tm
@@ -318,7 +318,7 @@ set packagetrace::showpresent 0 to skip <present/> output
#normalize
if {$is_exact} {
set req [lindex $v_requirements 0] ;#only one is allowed for -exact
- set v_requirement $req-$req ;#translate to v-v normalised equiv of -exact
+ set v_requirements $req-$req ;#translate to v-v normalised equiv of -exact
} else {
set reqs [list]
foreach req $v_requirements {
diff --git a/src/vfs/_vfscommon.vfs/modules/packagetrace-0.9.tm b/src/vfs/_vfscommon.vfs/modules/packagetrace-0.9.tm
new file mode 100644
index 00000000..59697f78
--- /dev/null
+++ b/src/vfs/_vfscommon.vfs/modules/packagetrace-0.9.tm
@@ -0,0 +1,643 @@
+
+
+#JMN 2005 - Public Domain
+#
+#REVIEW: This package may not robustly output xml. More testing & development required.
+#
+
+#NOTE: the 'x' attribute on the 'info' tag may have its value truncated.
+#It is a human-readable indicator only and should not be used to cross-reference to the corresponding 'require' tag using the 'p' attribute.
+#Use the fact that the corresponding 'info' tag directly follows its 'require' tag.
+
+
+#changes
+#2021-09-17
+# - added variable ::packagetrace::showpresent with default 1
+# setting this to 0 will hide the <present/> tags which sometimes make the output too verbose.
+# - changed t from an integer number of milliseconds to show fractional millis by using ([clock microseconds]-$t0)/1000.0 in the expr.
+
+namespace eval packagetrace::class {
+ if {[info commands [namespace current]::tracer] eq ""} {
+ oo::class create tracer {
+ method get {} {
+ }
+ method test {} {
+ return tracertest
+ }
+ }
+ }
+}
+
+
+namespace eval packagetrace {
+ variable tracerlist [list]
+ variable chan stderr
+ variable showpresent 1
+ variable output ""
+
+
+ proc help {} {
+ return {
+ REVIEW - documentation inaccurate
+Enable package tracing using 'package require packagetrace'
+Disable package tracing using 'package forget packagetrace; package require packagetrace'
+ (This 2nd 'package require packagetrace' will raise an error. This is deliberate.)
+use packagetrace::channel <chan> to desired output channel or none. (default stderr)
+
+set packagetrace::showpresent 0 to skip <present/> output
+}
+ }
+
+ # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == ==
+ # Maintenance - tm_version... functions - primary source is punk::lib module
+ # - these should be synced with code from latest punk::lib
+ # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == ==
+ proc tm_version_isvalid {versionpart} {
+ #Needs to be suitable for use with Tcl's 'package vcompare'
+ if {![catch [list package vcompare $versionpart $versionpart]]} {
+ return 1
+ } else {
+ return 0
+ }
+ }
+ proc tm_version_major {version} {
+ if {![tm_version_isvalid $version]} {
+ error "Invalid version '$version' is not a proper Tcl module version number"
+ }
+ set firstpart [lindex [split $version .] 0]
+ #check for a/b in first segment
+ if {[string is integer -strict $firstpart]} {
+ return $firstpart
+ }
+ if {[string first a $firstpart] > 0} {
+ return [lindex [split $firstpart a] 0]
+ }
+ if {[string first b $firstpart] > 0} {
+ return [lindex [split $firstpart b] 0]
+ }
+ error "tm_version_major unable to determine major version from version number '$version'"
+ }
+ proc tm_version_canonical {ver} {
+ #accepts a single valid version only - not a bounded or unbounded spec
+ if {![tm_version_isvalid $ver]} {
+ error "tm_version_canonical version '$ver' is not valid for a package version"
+ }
+ set parts [split $ver .]
+ set newparts [list]
+ foreach o $parts {
+ set trimmed [string trimleft $o 0]
+ set firstnonzero [string index $trimmed 0]
+ switch -exact -- $firstnonzero {
+ "" {
+ lappend newparts 0
+ }
+ a - b {
+ #e.g 000bnnnn -> bnnnnn
+ set tailtrimmed [string trimleft [string range $trimmed 1 end] 0]
+ if {$tailtrimmed eq ""} {
+ set tailtrimmed 0
+ }
+ lappend newparts 0$firstnonzero$tailtrimmed
+ }
+ default {
+ #digit
+ if {[string is integer -strict $trimmed]} {
+ #e.g 0100 -> 100
+ lappend newparts $trimmed
+ } else {
+ #e.g 0100b003 -> 100b003 (still need to process tail)
+ if {[set apos [string first a $trimmed]] > 0} {
+ set lhs [string range $trimmed 0 $apos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch
+ set rhs [string range $trimmed $apos+1 end] ;#assert rhs non-empty and only digits
+ set rhs [string trimleft $rhs 0]
+ if {$rhs eq ""} {
+ set rhs 0
+ }
+ lappend newparts ${lhs}a${rhs}
+ } elseif {[set bpos [string first b $trimmed]] > 0} {
+ set lhs [string range $trimmed 0 $bpos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch
+ set rhs [string range $trimmed $bpos+1 end] ;#assert rhs non-empty and only digits
+ set rhs [string trimleft $rhs 0]
+ if {$rhs eq ""} {
+ set rhs 0
+ }
+ lappend newparts ${lhs}b${rhs}
+ } else {
+ #assert - shouldn't get here trimmed val should have been empty, an int or contained an a or b
+ error "tm_version_canonical error - trimfail - unexpected"
+ }
+ }
+ }
+ }
+ }
+ return [join $newparts .]
+ }
+ proc tm_version_required_canonical {versionspec} {
+ #also trim leading zero from any dottedpart?
+ #Tcl *allows* leading zeros in any of the dotted parts - but they are not significant.
+ #e.g 1.01 is equivalent to 1.1 and 01.001
+ #also 1b3 == 1b0003
+
+ if {[string trim $versionspec] eq ""} {return ""} ;#unspecified = any version
+ set errmsg "tm_version_required_canonical - invalid version specification"
+ if {[string first - $versionspec] < 0} {
+ #no dash
+ #looks like a minbounded version (ie a single version with no dash) convert to min-max form
+ set from $versionspec
+ if {![tm_version_isvalid $from]} {
+ error "$errmsg '$versionpec'"
+ }
+ if {![catch {tm_version_major $from} majorv]} {
+ set from [tm_version_canonical $from]
+ return "${from}-[expr {$majorv +1}]"
+ } else {
+ error "$errmsg '$versionspec'"
+ }
+ } else {
+ # min- or min-max
+ #validation and canonicalisation (strip leading zeroes from each segment, including either side of a or b)
+ set parts [split $versionspec -] ;#we expect only 2 parts
+ lassign $parts from to
+ if {![tm_version_isvalid $from]} {
+ error "$errmsg '$versionspec'"
+ }
+ set from [tm_version_canonical $from]
+ if {[llength $parts] == 2} {
+ if {$to ne ""} {
+ if {![tm_version_isvalid $to]} {
+ error "$errmsg '$versionspec'"
+ }
+ set to [tm_version_canonical $to]
+ return $from-$to
+ } else {
+ return $from-
+ }
+ } else {
+ error "$errmsg '$versionspec'"
+ }
+ error "tm_version_required_canonical should have already returned a canonicalised versionspec - or produced an error with reason before this point"
+ }
+ }
+ # end tm_version... functions
+ # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == ==
+
+ #convenience function in case the sequence 'package forget packagetrace;package require packagetrace' is too unintuitive or weird.
+ #REVIEW
+ proc unload {} {
+ package forget packagetrace
+ if {[catch {package require packagetrace}]} {
+ return 1 ;#yes - we get an error if we unloaded successfully
+ } else {
+ error "packagetrace was not unloaded"
+ }
+ }
+ proc emit {str} {
+ variable chan
+ variable output
+ append output $str
+ if {$chan ne "none"} {
+ puts -nonewline $chan $str
+ }
+ return
+ }
+ proc get {{as raw}} {
+ variable output
+ switch -- [string tolower $as] {
+ asxml {
+ if {[package provide tdom] eq ""} {
+ set previous_output $output
+ package require tdom
+ set output $previous_output
+ }
+ set d [dom parse $output]
+ return [$d asXML]
+ }
+ aslist {
+ if {[package provide tdom] eq ""} {
+ set previous_output $output
+ package require tdom
+ set output $previous_output
+ }
+ set d [dom parse $output]
+ return [$d asList]
+ }
+ default {
+ return $output
+ }
+ }
+ }
+ proc channel {{ch ""}} {
+ variable chan
+ switch -exact -- $ch {
+ "" {
+ return $chan
+ }
+ none {
+ set chan none
+ return none
+ }
+ stderr - stdout {
+ #note stderr stdout not necessarily in [chan names] (due to transforms etc?) but can still work
+ set chan $ch
+ return $ch
+ }
+ default {
+ if {$ch in [chan names]} {
+ set chan $ch
+ return $ch
+ } else {
+ error "chan '$ch' not in \[chan names\]: [chan names]"
+ }
+ }
+ }
+ }
+ proc init {} {
+ uplevel 1 {
+ set ::packagetrace::level -1
+ if {![llength [info commands tcl_findLibrary]]} {
+ tcl::namespace::eval :: $::auto_index(tcl_findLibrary)
+ }
+ package require commandstack
+
+
+ set targetcommand [namespace which tcl_findLibrary] ;# normalize to presumably ::tcl_findLibrary
+ set stackrecord [commandstack::rename_command -renamer packagetrace $targetcommand [info args $targetcommand] {
+ set marg [string repeat { } $::packagetrace::level]
+ packagetrace::emit "${marg}<extra> tcl_findLibrary $basename $version $patch $initScript $enVarName $varName </extra>\n"
+ uplevel 1 [list $COMMANDSTACKNEXT $basename $version $patch $initScript $enVarName $varName]
+ }]
+ if {[dict get $stackrecord implementation] ne ""} {
+ set old_tcl_findLibrary [dict get $stackrecord implementation]
+ puts stderr "packagetrace::init renamed $targetcommand to $old_tcl_findLibrary and is providing an override"
+ } else {
+ puts stderr "packagetrace::init failed to rename $targetcommand"
+ }
+
+
+
+ set package_command [namespace which package]
+ set stackrecord [commandstack::rename_command -renamer packagetrace $package_command {subcommand args} {
+ set tracerlist $::packagetrace::tracerlist
+ set tracer [lindex $tracerlist end]
+ if {$tracer eq ""} {
+
+ }
+ set ch $::packagetrace::chan
+ set next $COMMANDSTACKNEXT
+ if {$next ne "$COMMANDSTACKNEXT_ORIGINAL"} {
+ puts stderr "(packagetrace package) DEBUG - command changed since start: $COMMANDSTACKNEXT_ORIGINAL is now $next"
+ }
+
+ #cache $ch instead of using upvar,
+ #because namespace may be deleted during call.
+
+ #!todo - optionally silence Tcl & Tk requires to reduce output?
+ #if {[lindex $args 0] eq "Tcl"} {
+ # return [$next $subcommand {*}$args]
+ #}
+ switch -exact -- [tcl::prefix::match {files forget ifneeded names prefer present provide require unknown vcompare versions vsatisfies} $subcommand] {
+ require {
+ #columns
+ set c1 [string repeat { } 30] ;#tree col
+ set c1a " "
+ set c2 [string repeat { } 20] ;#package name col
+ set c2a " " ;# close require/present tags
+ set c3 [string repeat { } 18] ;#version col - must handle v= "999999.0a1.0" without truncation
+ set c4 [string repeat { } 12] ;#timing col 5 chars of punct leaving remainder for value.
+ set c5 [string repeat { } 10] ;#module col
+ set c5a [string repeat { } 3] ;#close result tag col
+
+ #we assume 'package require' API sticks to solo option flags like -exact and is relatively stable.
+ set argidx 0
+ set is_exact 0
+ foreach a $args {
+ if {[string range $a 0 0] ne "-"} {
+ #assume 1st non-dashed argument is package name
+ set pkg $a
+ set v_requirements [lrange $args $argidx+1 end]
+ #normalize
+ if {$is_exact} {
+ set req [lindex $v_requirements 0] ;#only one is allowed for -exact
+ set v_requirements $req-$req ;#translate to v-v normalised equiv of -exact
+ } else {
+ set reqs [list]
+ foreach req $v_requirements {
+ lappend reqs [::packagetrace::tm_version_required_canonical $req] ;#empty remains empty, v -> v-<majorv+1>, leading zeros stripped from all segments.
+ }
+ set v_requirements $reqs ;#each normalised
+ }
+ set pkg_ [lrange $args $argidx end] ;# raw e.g "Tcl 8.6" or "Tcl 8.5 9"
+ break
+ } else {
+ if {$a eq "-exact"} {
+ set is_exact 1
+ }
+ }
+ incr argidx
+ }
+
+
+ incr ::packagetrace::level
+ if {$::packagetrace::level == 0} {
+ set packagetrace::output ""
+ }
+
+
+ set marg [string repeat { } $::packagetrace::level]
+ set margnext [string repeat { } [expr {$::packagetrace::level + 1}]]
+
+ if {![catch {set ver [$next present {*}$args]}]} {
+ if {$::packagetrace::showpresent} {
+ #already loaded..
+ set f1 [packagetrace::overtype::left $c1 "${marg}<present"]
+ set f2 [packagetrace::overtype::left -overflow 1 $c2 "p= \"$pkg_\""] ;#disallow truncation!
+ set f2a $c2a
+ set f3 [packagetrace::overtype::left $c3 "v= \"$ver\""]
+ set f4 $c4
+ set f5 $c5
+ set f5a "/> "
+ #puts -nonewline $ch $f1$c1a$f2$f2a$f3$f4$f5\n
+ packagetrace::emit $f1$c1a$f2$f2a$f3$f4$f5$f5a\n
+ }
+ } else {
+ set f1 [packagetrace::overtype::left $c1 "${marg}<require"]
+ set f2 [packagetrace::overtype::left -overflow 1 $c2 "p= \"$pkg_\""] ;#disallow truncation!
+ set f2a $c2a
+ set f3 $c3
+ set f4 $c4
+ set f5 $c5
+ set f5a " > "
+ #puts -nonewline $ch $f1$c1a$f2$f2a$f3$f4$f5\n
+ packagetrace::emit $f1$c1a$f2$f2a$f3$f4$f5$f5a\n
+
+ set errMsg ""
+ #set t0 [clock clicks -milliseconds]
+ set t0 [clock microseconds]
+
+ if {[catch {set ver [$next require {*}$args]} errMsg]} {
+ set ver ""
+ #
+ #NOTE error must be raised at some point - see below
+ }
+ #set t [expr {[clock clicks -millisec]-$t0}]
+ set t [expr {([clock microseconds]-$t0)/1000.0}]
+
+
+
+
+ #jmn
+ set f1 [packagetrace::overtype::left $c1 "${margnext}<info "]
+ #set f1a "<info "
+ set f1a ""
+
+ set f2 [packagetrace::overtype::left -ellipsis 1 [string range $c2 0 end-1] "x= \"$args"]
+ if {[string length [string trimright $f2]] <= [expr [string length $c2]-1]} {
+ #right-trimmed value shorter than field.. therefore we need to close attribute
+ set f2 [packagetrace::overtype::left $c2 [string trimright $f2]\"]
+ }
+
+ #we use the attributename x because this is not necessarily the same as p! may be truncated.
+
+ set f3 [packagetrace::overtype::left $c3 "v= \"$ver\""]
+
+ #truncate time to c4 width - possibly losing some precision. If truncated - add closing double quote.
+ set f4 [packagetrace::overtype::left -overflow 1 $c4 "t= \"[lrange $t 0 1]\""]
+ if {[string length [string trimright $f4]] > [expr {[string length $c4]}]} {
+ set f4 "[packagetrace::overtype::left [string range $c4 0 end-1] [string trimright $f4]]\""
+ }
+
+ if {[string length $ver]} {
+ set num ""
+ foreach c [split $ver ""] {
+ if {[string is digit $c] || $c eq "."} {
+ append num $c
+ } else {
+ break
+ }
+ }
+ set ver $num
+
+ #review - scr not guaranteed to be valid tcl list - should parse properly?
+ set scr [$next ifneeded $pkg $ver]
+ if {[string range $scr end-2 end] ne ".tm"} {
+ set f5 $c5
+ } else {
+ #!todo - optionally output module path instead of boolean?
+ #set f5 [packagetrace::overtype::left -ellipsis 1 -ellipsistext ... [string range $c5 0 end-1] "tm= \"[lindex $scr end]"]
+ set f5 [packagetrace::overtype::left -ellipsis 1 -ellipsistext ... [string range $c5 0 end-1] "tm= \"1"]
+ if {[string length [string trimright $f5]] <= [expr [string length $c5]-1]} {
+ set f5 [packagetrace::overtype::left $c5 [string trimright $f5]\"]
+ }
+ }
+ } else {
+ set f5 $c5
+ }
+
+ set f5a [packagetrace::overtype::left $c5a "/>"] ;#end of <info
+ #puts -nonewline $ch "$f1$c1a$f2$c2a$f3$f4 $f5$f5a\n"
+ packagetrace::emit "$f1$c1a$f2$c2a$f3$f4 $f5$f5a\n"
+
+
+ set f1 [packagetrace::overtype::left $c1 "${marg}</require>"]
+ set f1a ""
+ set f2 ""
+ set c2a ""
+ set f3 ""
+ set f4 ""
+ set f5 ""
+ set f5a ""
+ #puts -nonewline $ch $f1$f1a$f2$c2a$f3$f4$f5$f5a\n
+ packagetrace::emit $f1$f1a$f2$c2a$f3$f4$f5$f5a\n
+
+
+ if {![string length $ver]} {
+ if {[lindex $args 0] eq "packagetrace"} {
+ #REVIEW - what is going on here?
+ namespace delete ::packagetrace::overtype
+ }
+
+ #we must raise an error if original 'package require' would have
+ incr ::packagetrace::level -1
+ error $errMsg
+ }
+
+ }
+ incr ::packagetrace::level -1
+ return $ver
+ }
+ vcompare - vsatisifies - provide - ifneeded {
+ set result [$next $subcommand {*}$args]
+ #puts -nonewline $ch " -- package $subcommand $args\n"
+ return $result
+ }
+ default {
+ set result [$next $subcommand {*}$args]
+ #puts $ch "*** here $subcommand $args"
+ return $result
+ }
+ }
+
+ }]
+ if {[set stored_target [dict get $stackrecord implementation]] ne ""} {
+ puts stderr "packagetrace::init renamed $package_command to $stored_target and is providing an override"
+ set f1 [string repeat { } 30]
+ #set f1a " "
+ set f1a ""
+ set f2 [packagetrace::overtype::left [string repeat { } 20] "PACKAGE"]
+ set f2a " "
+ set f3 [packagetrace::overtype::left [string repeat { } 15] "VERSION"]
+ set f4 [packagetrace::overtype::left [string repeat { } 12] "LOAD-ms"]
+ set f5 [packagetrace::overtype::left [string repeat { } 10] "MODULE"]
+
+ #puts -nonewline $::packagetrace::chan "-$f1$f1a$f2$f2a$f3$f4$f5\n"
+ #packagetrace::emit "-$f1$f1a$f2$f2a$f3$f4$f5\n"
+ puts -nonewline stderr "-$f1$f1a$f2$f2a$f3$f4$f5\n"
+ unset f1 f1a f2 f2a f3 f4 f5
+ } else {
+ puts stderr "packagetrace::init failed to rename $package_command"
+ }
+ }
+ }
+}
+
+
+
+#The preferred source of the ::overtype::<direction> functions is the 'overtype' package
+# - pasted here because packagetrace should have no extra dependencies.
+# - overtype package has better support for ansi and supports wide chars
+namespace eval packagetrace::overtype {set version INLINE}
+
+namespace eval packagetrace::overtype {
+ proc left {args} {
+ # @c overtype starting at left (overstrike)
+ # @c can/should we use something like this?: 'format "%-*s" $len $overtext
+
+ if {[llength $args] < 2} {
+ error {usage: ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext}
+ }
+ foreach {undertext overtext} [lrange $args end-1 end] break
+
+ set opt(-ellipsis) 0
+ set opt(-ellipsistext) {...}
+ set opt(-overflow) 0
+ array set opt [lrange $args 0 end-2]
+
+
+ set len [string length $undertext]
+ set overlen [string length $overtext]
+ set diff [expr {$overlen - $len}]
+ if {$diff > 0} {
+ if {$opt(-overflow)} {
+ return $overtext
+ } else {
+ if {$opt(-ellipsis)} {
+ return [right [string range $overtext 0 [expr {$len -1}]] $opt(-ellipsistext)]
+ } else {
+ return [string range $overtext 0 [expr {$len -1}]]
+ }
+ }
+ } else {
+
+ return "$overtext[string range $undertext $overlen end]"
+ }
+ }
+
+ proc centre {args} {
+ if {[llength $args] < 2} {
+ error {usage: ?-bias [left|right]? ?-overflow [1|0]? undertext overtext}
+ }
+ foreach {undertext overtext} [lrange $args end-1 end] break
+
+ set opt(-bias) left
+ set opt(-overflow) 0
+ array set opt [lrange $args 0 end-2]
+
+
+ set olen [string length $overtext]
+ set ulen [string length $undertext]
+ set diff [expr {$ulen - $olen}]
+ if {$diff > 0} {
+ set half [expr {round(int($diff / 2))}]
+ if {[string match right $opt(-bias)]} {
+ if {[expr {2 * $half}] < $diff} {
+ incr half
+ }
+ }
+
+ set rhs [expr {$diff - $half - 1}]
+ set lhs [expr {$half - 1}]
+
+ set a [string range $undertext 0 $lhs]
+ set b $overtext
+ set c [string range $undertext end-$rhs end]
+ return $a$b$c
+ } else {
+ if {$diff < 0} {
+ if {$opt(-overflow)} {
+ return $overtext
+ } else {
+ return [string range $overtext 0 [expr {$ulen - 1}]]
+ }
+ } else {
+ return $overtext
+ }
+ }
+ }
+
+ proc right {args} {
+ if {[llength $args] < 2} {
+ error {usage: ?-overflow [1|0]? undertext overtext}
+ }
+ lassign [lrange $args end-1 end] undertext overtext
+
+ set opt(-overflow) 0
+ array set opt [lrange $args 0 end-2]
+
+ set olen [string length $overtext]
+ set ulen [string length $undertext]
+
+ if {$opt(-overflow)} {
+ return [string range $undertext 0 end-$olen]$overtext
+ } else {
+ if {$olen > $ulen} {
+ set diff [expr {$olen - $ulen}]
+ return [string range $undertext 0 end-$olen][string range $overtext 0 end-$diff]
+ } else {
+ return [string range $undertext 0 end-$olen]$overtext
+ }
+ }
+ }
+
+}
+
+
+
+
+
+proc packagetrace::deinit {} {
+ packagetrace::disable
+ #namespace delete packagetrace
+ #package forget packagetrace
+}
+proc packagetrace::disable {} {
+ ::commandstack::remove_rename {::tcl_findLibrary packagetrace}
+ ::commandstack::remove_rename {::package packagetrace}
+}
+proc packagetrace::enable {} {
+ #init doesn't clear state - so this is effectively an alias
+ tailcall packagetrace::init
+}
+
+#clear state - reset to defaults
+proc packagetrace::clear {} {
+ variable chan
+ set chan stderr
+ variable showpresent
+ set showpresent 1
+}
+
+package provide packagetrace [namespace eval packagetrace {
+ set version 0.9
+}]
+
+
diff --git a/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm
index 08359461..738d89c5 100644
--- a/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm
+++ b/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm
@@ -49,6 +49,17 @@ namespace eval punk {
}
set has_commandstack [expr {![catch {package require commandstack}]}]
+ if {$has_commandstack} {
+ if {[catch {
+ package require punk::packagepreference
+ } errM]} {
+ catch {puts stderr "Failed to load punk::packagepreference"}
+ }
+ catch punk::packagepreference::install
+ } else {
+ #
+ }
+
if {![interp issafe] && $has_commandstack && $::tcl_platform(platform) eq "windows"} {
#still a caching version of auto_execok - but with proper(fixed) search order
@@ -353,18 +364,12 @@ punk::aliascore::init
package require punk::repl::codethread
package require punk::config
#package require textblock
-package require punk::console
+package require punk::console ;#requires Thread
package require punk::ns
package require punk::winpath ;# for windows paths - but has functions that can be called on unix systems
package require punk::repo
package require punk::du
package require punk::mix::base
-if {[catch {
- package require punk::packagepreference
-} errM]} {
- puts stderr "Failed to load punk::packagepreference"
-}
-punk::packagepreference::install
namespace eval punk {
# -- --- ---
diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.0.tm
index 78a18304..37f8b712 100644
--- a/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.0.tm
+++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.0.tm
@@ -332,9 +332,11 @@ tcl::namespace::eval punk::args {
(used for trailing args that come after switches/opts)
%B%@argdisplay%N% ?opt val...?
options -header <str> (text for header row of table)
- -body <str> (text to replace entirety of autogenerated docs)
+ -body <str> (text to replace autogenerated arg info)
%B%@doc%N% ?opt val...?
options -name <str> -url <str>
+ %B%@seealso%N% ?opt val...?
+ options -name <str> -url <str> (for footer - unimplemented)
Some other options normally present on custom arguments are available
to use with the @leaders @opts @values directives to set defaults
@@ -842,7 +844,7 @@ tcl::namespace::eval punk::args {
#id An id will be allocated if no id line present or the -id value is "auto"
if {$DEF_definition_id ne ""} {
#disallow duplicate @id line
- error "punk::args::define - @id already set. Existing value $DEF_definition_id"
+ error "punk::args::define - @id already set. Existing value $DEF_definition_id\n[join $args \n]"
}
if {[dict exists $at_specs -id]} {
set DEF_definition_id [dict get $at_specs -id]
@@ -966,7 +968,7 @@ tcl::namespace::eval punk::args {
-anyopts {
set opt_any $v
}
- -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted {
+ -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted {
#review - only apply to certain types?
tcl::dict::set tmp_optspec_defaults $k $v
}
@@ -1012,7 +1014,7 @@ tcl::namespace::eval punk::args {
tcl::dict::set tmp_optspec_defaults $k $v
}
default {
- set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\
+ set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\
-nominsize -nomaxsize -norange -nochoices -nochoicelabels\
-type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\
-regexprepass -regexprefail -regexprefailmsg -validationtransform\
@@ -1050,7 +1052,7 @@ tcl::namespace::eval punk::args {
}
dict set F $fid LEADER_MAX $v
}
- -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase {
+ -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase {
#review - only apply to certain types?
tcl::dict::set tmp_leaderspec_defaults $k $v
}
@@ -1097,8 +1099,9 @@ tcl::namespace::eval punk::args {
}
default {
set known { -min -minvalues -max -maxvalues\
- -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\
- -nominsize -nomaxsize -norange -nochoices -nochoicelabels\
+ -minsize -maxsize -range\
+ -choices -choicegroups -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\
+ -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\
-type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\
-regexprepass -regexprefail -regexprefailmsg -validationtransform\
}
@@ -1135,7 +1138,7 @@ tcl::namespace::eval punk::args {
}
set val_max $v
}
- -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase {
+ -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase {
#review - only apply to certain types?
tcl::dict::set tmp_valspec_defaults $k $v
}
@@ -1182,7 +1185,9 @@ tcl::namespace::eval punk::args {
}
default {
set known { -min -minvalues -max -maxvalues\
- -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\
+ -minsize -maxsize -range\
+ -choices -choicegroups -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\
+ -nocase\
-nominsize -nomaxsize -norange -nochoices -nochoicelabels\
-type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\
-regexprepass -regexprefail -regexprefailmsg -validationtransform\
@@ -1195,6 +1200,10 @@ tcl::namespace::eval punk::args {
}
}
+ seealso {
+ #todo!
+ #like @doc, except displays in footer, multiple - sub-table?
+ }
default {
error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @argdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id"
}
@@ -1321,7 +1330,9 @@ tcl::namespace::eval punk::args {
}
}
}
- -default - -solo - -range - -choices - -choicegroups - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -minsize - -maxsize - -nocase - -optional - -multiple -
+ -default - -solo - -range -
+ -choices - -choicegroups - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -choiceinfo -
+ -minsize - -maxsize - -nocase - -optional - -multiple -
-validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE -
-regexprepass - -regexprefail - -regexprefailmsg
{
@@ -1528,80 +1539,181 @@ tcl::namespace::eval punk::args {
return $argdata_dict
}
- lappend PUNKARGS [list -dynamic 0 {
- @id -id ::punk::args::get_spec
- @cmd -name punk::args::get_definition -help\
- ""
- id -type string -help\
- "identifer for punk::args defintion
- This will usually be a fully-qualifed
- path for a command name"
- patternlist -type list -optional 1 -default * -help\
- "glob-style patterns for retrieving value or switch
- definitions. If ommitted or passed an empty string,
- the raw unresolved definition will be returned as
- a list, including possible leading flags such as
- -dynamic 0|1.
- If specified as * - the entire definition including
- directive lines will be returned in line form.
- (directives are lines beginning with
- @ e.g @id, @cmd etc)
- "
- override_dict -type dict -optional 1 -default "" -help\
- "unimplemented.
- Will allow overriding or adding flags to a returned
- definition line.
- "
- }]
- #rename get_definition ???
- proc get_spec {id args} {
- lassign $args patternlist override_dict
- if {[llength $args] > 2} {
- punk::args::get_by_id ::punk::args::get_spec [list $id {*}$args]
- return
+ #return raw definition list as created with 'define'
+ proc rawdef {id} {
+ variable argdefcache_by_id
+ set realid [real_id $id]
+ #return the raw definition - possibly with unresolved dynamic parts
+ if {![dict exists $argdefcache_by_id $realid]} {
+ return ""
}
- if {[llength $override_dict] % 2 != 0} {
- #malformed dict
- punk::args::get_by_id ::punk::args::get_spec [list $id {*}$args]
+ return [tcl::dict::get $argdefcache_by_id $realid]
+ }
+
+
+ namespace eval argdoc {
+ variable resolved_def_TYPE_CHOICES {* @id @cmd @leaders @opts @values @doc}
+
+ lappend PUNKARGS [list -dynamic 0 [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES] {
+ @id -id ::punk::args::resolved_def
+ @cmd -name punk::args::resolved_def -help\
+ ""
+ @leaders -min 0 -max 0
+ @opts
+ -form -default 0 -help\
+ "UNIMPLEMENTED
+ Ordinal index or name of command form"
+ -type -default * -choices {%TYPECHOICES%} -choiceprefix 0 -multiple 1
+ -override -type dict -optional 1 -default "" -help\
+ "dict of dicts. Key in outer dict is the name of a
+ directive or an argument. Inner dict is a map of
+ overrides/additions (-<flag> <newval>...) for that line.
+ (unimplemented).
+ "
+ @values -min 1 -max -1
+ id -type string -help\
+ "identifer for a punk::args definition
+ This will usually be a fully-qualifed
+ path for a command name"
+ pattern -type string -optional 1 -default * -multiple 1 -help\
+ "glob-style patterns for retrieving value or switch
+ definitions.
+
+ If -type is * and pattern is * the entire definition including
+ directive lines will be returned in line form.
+ (directives are lines beginning with
+ @ e.g @id, @cmd etc)
+
+ if -type is @leaders,@opts or @values matches from that type
+ will be returned.
+
+ if -type is another directive such as @id, @doc etc the
+ patterns are ignored.
+
+ "
+ }]]
+ }
+
+
+ proc resolved_def {args} {
+ set opts [dict create\
+ -type {}\
+ -form 0\
+ -override {}\
+ ]
+ if {[llength $args] < 1} {
+ #must have at least id
+ punk::args::get_by_id ::punk::args::resolved_def $args
return
}
+ set patterns [list]
+
+ #a definition id must not begin with "-"
+ for {set i 0} {$i < [llength $args]} {incr i} {
+ set a [lindex $args $i]
+ if {$a eq "-type"} {
+ incr i
+ dict lappend opts -type [lindex $args $i]
+ } elseif {[string match -* $a]} {
+ incr i
+ dict set opts $a [lindex $args $i]
+ } else {
+ set id [lindex $args $i]
+ set patterns [lrange $args $i+1 end]
+ break
+ }
+ if {$i == [llength $args]-1} {
+ punk::args::get_by_id ::punk::args::resolved_def $args
+ return
+ }
+ }
+ if {![llength $patterns]} {
+ set patterns [list *]
+ }
+ dict for {k v} $opts {
+ switch -- $k {
+ -form - -type - -override {}
+ default {
+ punk::args::get_by_id ::punk::args::resolved_def $args
+ return
+ }
+ }
+ }
+ set typelist [dict get $opts -type]
+ if {[llength $typelist] == 0} {
+ set typelist {*}
+ }
+ foreach type $typelist {
+ if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} {
+ punk::args::get_by_id ::punk::args::resolved_def $args
+ return
+ }
+ }
variable argdefcache_by_id
set realid [real_id $id]
+
if {$realid ne ""} {
- if {$patternlist eq ""} {
- #return the raw definition - possibly with unresolved dynamic parts
- return [tcl::dict::get $argdefcache_by_id $realid]
- } else {
- set deflist [tcl::dict::get $argdefcache_by_id $realid]
- set result ""
- set specdict [uplevel 1 [list ::punk::args::define {*}$deflist]]
- set arg_info [dict get $specdict ARG_INFO]
- foreach pat $patternlist {
- if {[string match $pat @id]} {
+ set deflist [tcl::dict::get $argdefcache_by_id $realid]
+ set result ""
+ set specdict [uplevel 1 [list ::punk::args::define {*}$deflist]]
+ set arg_info [dict get $specdict ARG_INFO]
+ set argtypes [dict create @opts option @leaders leader @values value]
+ foreach type $typelist {
+ switch -exact -- $type {
+ * {
+ append result \n "@id -id [dict get $specdict id]"
+ append result \n "@cmd [dict get $specdict cmd_info]"
+ append result \n "@doc [dict get $specdict doc_info]"
+ foreach tp {leader option value} {
+ foreach pat $patterns {
+ set matches [dict keys $arg_info $pat]
+ foreach m $matches {
+ set def [dict get $arg_info $m]
+ if {[dict get $def -ARGTYPE] eq $tp} {
+ set def [dict remove $def -ARGTYPE]
+ append result \n "$m $def"
+ }
+ }
+ }
+ }
+
+ }
+ @id {
#only a single id record can exist
append result \n "@id -id [dict get $specdict id]"
}
- if {[string match $pat @cmd]} {
+ @cmd {
#only a single @cmd record can exist
#merged if multiple in original def (?)
append result \n "@cmd [dict get $specdict cmd_info]"
}
- #todo @leaders, @opts, @values lines
- #can be multiple of each. We need to preserve order and interleave
- #with any matching arg_info results.
- #requires storing more info in the internal spec dictionary
- set matches [dict keys $arg_info $pat]
- foreach m $matches {
- set def [dict get $arg_info $m]
- set def [dict remove $def -ARGTYPE]
- append result \n "$m $def"
+ @doc {
+ #only a single @doc record can exist
+ append result \n "@doc [dict get $specdict doc_info]"
+ }
+ @leaders - @opts - @values {
+ #option,
+ foreach pat $patterns {
+ set matches [dict keys $arg_info $pat]
+ foreach m $matches {
+ set def [dict get $arg_info $m]
+ if {[dict get $def -ARGTYPE] eq [dict get $argtypes $type]} {
+ set def [dict remove $def -ARGTYPE]
+ append result \n "$m $def"
+ }
+ }
+ }
+ }
+ default {
}
}
- return $result
}
+
+ return $result
}
}
+
proc get_spec_values {id {patternlist *}} {
variable argdefcache_by_id
set realid [real_id $id]
@@ -1636,13 +1748,14 @@ tcl::namespace::eval punk::args {
#proc get_spec_opts ??
proc get_def {id} {
- if {[id_exists $id]} {
- return [define {*}[get_spec $id]]
- }
+ return [define {*}[rawdef $id]]
+ #if {[id_exists $id]} {
+ # return [define {*}[rawdef $id]]
+ #}
}
proc is_dynamic {id} {
- set spec [get_spec $id]
- return [expr {[lindex $spec 0] eq "-dynamic" && [lindex $spec 1]} ]
+ set deflist [rawdef $id]
+ return [expr {[lindex $deflist 0] eq "-dynamic" && [lindex $deflist 1]} ]
}
variable aliases
@@ -1661,6 +1774,8 @@ tcl::namespace::eval punk::args {
variable aliases
return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $argdefcache_by_id $match]]
}
+
+ #we don't automatically test for (autodef)$id - only direct ids and aliases
proc id_exists {id} {
variable argdefcache_by_id
variable aliases
@@ -1694,6 +1809,9 @@ tcl::namespace::eval punk::args {
return $id
} else {
if {![llength [update_definitions]]} {
+ if {[tcl::dict::exists $argdefcache_by_id (autodef)$id]} {
+ return (autodef)$id
+ }
return ""
} else {
if {[tcl::dict::exists $aliases $id]} {
@@ -1702,6 +1820,9 @@ tcl::namespace::eval punk::args {
if {[tcl::dict::exists $argdefcache_by_id $id]} {
return $id
}
+ if {[tcl::dict::exists $argdefcache_by_id (autodef)$id]} {
+ return (autodef)$id
+ }
return ""
}
}
@@ -1797,7 +1918,7 @@ tcl::namespace::eval punk::args {
@values -min 0 -max 0
}]
proc test_get_dict {args} {
- punk::args::get_dict {*}[punk::args::get_spec ::punk::args::test1] $args
+ punk::args::get_dict {*}[punk::args::rawdef ::punk::args::test1] $args
}
proc test_get_by_id {args} {
punk::args::get_by_id ::punk::args::test1 $args
@@ -2558,7 +2679,7 @@ tcl::namespace::eval punk::args {
mechanism and call this as necessary.
"
-return -default table -choices {string table tableobject}
- } {${[punk::args::get_spec ::punk::args::arg_error -scheme]}} {
+ } {${[punk::args::resolved_def -type @opts ::punk::args::arg_error -scheme]}} {
@values -min 0 -max 1
id -help\
@@ -2568,7 +2689,7 @@ tcl::namespace::eval punk::args {
proc usage {args} {
lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received
set id [dict get $values id]
- set definitionlist [get_spec $id]
+ set definitionlist [rawdef $id]
if {[llength $definitionlist] == 0} {
error "punk::args::usage - no such id: $id"
}
@@ -2589,7 +2710,7 @@ tcl::namespace::eval punk::args {
#deprecate?
proc get_by_id {id arglist} {
- set definitionlist [punk::args::get_spec $id]
+ set definitionlist [punk::args::rawdef $id]
if {[llength $definitionlist] == 0} {
error "punk::args::get_by_id - no such id: $id"
}
@@ -2633,6 +2754,25 @@ tcl::namespace::eval punk::args {
-errorstyle -type string -default enhanced -choices {enhanced standard minimal}
@values -min 3
sep -optional 0 -choices "--"
+
+
+ @form -form withid -synopsis "parse ?-form {int|<formname>...}? ?-errorstyle <choice>? -- withid $id"
+ withid -type literal -help\
+ "The literal value 'withid'"
+ id -type string -help\
+ "id of punk::args definition for a command"
+
+
+ @form -form withdef -synopsis "parse ?-form {int|<formname>...}? ?-errorstyle <choice>? -- withdef $def ?$def?"
+ withdef -type literal -help\
+ "The literal value 'withdef'"
+ def -type string -multiple 1 -optional 0 -help\
+ "Each remaining argument is a block of text
+ defining argument definitions.
+ As a special case, -dynamic <bool> may be
+ specified as the 1st 2 arguments. These are
+ not treated as an indicator to punk::args
+ about how to process the definition."
}]
proc parse {args} {
@@ -2669,7 +2809,8 @@ tcl::namespace::eval punk::args {
return "parse [llength $arglist] args withid $id, options:$opts"
}
withdef {
- if {[llength [lrange $args $split+3 end]] < 1} {
+ set deflist [lrange $args $split+3 end]
+ if {[llength $deflist] < 1} {
error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'"
}
return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts"
@@ -4173,7 +4314,7 @@ tcl::namespace::eval punk::args::lib {
# set PUNKARGS ""
#}
-lappend ::punk::args::register::NAMESPACES ::punk::args ::punk::args::lib
+lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm
index 25fad906..2331245c 100644
--- a/src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm
+++ b/src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm
@@ -171,40 +171,6 @@ tcl::namespace::eval punk::args::tclcore {
} "@doc -name Manpage: -url [manpage_tcl library]" ]
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---
- #categorise array subcommands based on currently known groupings.
- #we do this dynamically because Tcl ensembles (even some core ones) can have subcommands added at runtime.
- proc array_subcommands {} {
- package require punk::ns
- set subdict [punk::ns::ensemble_subcommands array]
- set expected_searchcmds {startsearch anymore nextelement donesearch}
- set searchcmds [list]
- foreach sc $expected_searchcmds {
- if {$sc in [dict keys $subdict]} {
- lappend searchcmds $sc
- }
- }
- set argdef ""
- append argdef "subcommand -choicegroups \{" \n
- append argdef " \"\" \{" \n
- append argdef " [dict keys [dict remove $subdict {*}$searchcmds]]" \n
- append argdef " \}" \n
- append argdef " \"search\" \{" \n
- append argdef " $searchcmds" \n
- append argdef " \}" \n
- append argdef " \} -choicecolumns 4 " \n
-
- return $argdef
- }
-
- lappend PUNKARGS [list -dynamic 1 {
- @id -id ::array
- @cmd -name "Builtin: array" -help\
- "Manipulate array variables"
- @values
- ${[punk::args::tclcore::array_subcommands]}
-
- } "@doc -name Manpage: -url [manpage_tcl array]" ]
-
#todo - make generic - take command and known_groups_dict
proc info_subcommands {} {
package require punk::ns
@@ -571,8 +537,113 @@ tcl::namespace::eval punk::args::tclcore {
"A list of PIDs"
} "@doc -name Manpage: -url [manpage_tcl namespace]" ]
+ ############################################################################################################################################################
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ # COMMANDS A-H
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ ############################################################################################################################################################
+
+ namespace eval argdoc {
+ #categorise array subcommands based on currently known groupings.
+ #we do this dynamically because Tcl ensembles (even some core ones) can have subcommands added at runtime.
+ proc array_subcommands {} {
+ package require punk::ns
+ set subdict [punk::ns::ensemble_subcommands array]
+ set expected_searchcmds {startsearch anymore nextelement donesearch}
+ set searchcmds [list]
+ foreach sc $expected_searchcmds {
+ if {$sc in [dict keys $subdict]} {
+ lappend searchcmds $sc
+ }
+ }
+ set argdef ""
+ append argdef "subcommand -choicegroups \{" \n
+ append argdef " \"\" \{" \n
+ append argdef " [dict keys [dict remove $subdict {*}$searchcmds]]" \n
+ append argdef " \}" \n
+ append argdef " \"search\" \{" \n
+ append argdef " $searchcmds" \n
+ append argdef " \}" \n
+ append argdef " \} -choicecolumns 4 " \n
+
+ return $argdef
+ }
+ }
+
+ lappend PUNKARGS [list -dynamic 1 {
+ @id -id ::array
+ @cmd -name "Builtin: array" -help\
+ "Manipulate array variables"
+ @values
+ ${[punk::args::tclcore::argdoc::array_subcommands]}
+
+ } "@doc -name Manpage: -url [manpage_tcl array]" ]
+
+
+
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ lappend PUNKARGS [list -dynamic 1 {
+ @id -id ::const
+ @cmd -name "Builtin: const" -help\
+ "Create and initialise a constant.
+
+ This command is normally used within a procedure body (or method body,
+ or lambda term) to create a constant within that procedure, or within a
+ namespace eval body to create a constant within that namespace. The
+ constant is an unmodifiable variable, called varName, that is initialised
+ with value. The result of const is always the empty string on success.
+ If a variable varname does not exist, it is create with its value set to
+ value and marked as a constant; this means that no other command (e.g set,
+ append, incr, unset) may modify or remove the variable; variables are
+ checked for whether they are constants before any traces are called. If a
+ variable varName already exists, it is an error unless that variable is
+ marked as a constant (in which case const is a no-op)
+
+ The varName may not be a qualified name or reference an element of an
+ array by any means. If the variable exists and is an array, that is an
+ error. Constants are normally only removed by their containing procedure
+ exiting or their namespace being deleted.
+ "
+ @values -min 1 -max 2
+ varName -help ""
+ value
+
+ } "@doc -name Manpage: -url [manpage_tcl const]" ]
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+
+ ############################################################################################################################################################
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ # COMMANDS I-L
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ ############################################################################################################################################################
+
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ punk::args::define {
+ @id -id ::lrange
+ @cmd -name "builtin: lrange" -help\
+ "return one or more adjacent elements from a list.
+ The new list returned consists of elements first through last, inclusive.
+ The index values first and last are interpreted the same as index values
+ for the command 'string index', supporting simple index arithmetic and
+ indices relative to the end of the list.
+ e.g lrange {a b c} 0 end-1
+ "
+ @values -min 3 -max 3
+ list -type list -help\
+ "tcl list as a value"
+ first -help\
+ "index expression for first element"
+ last -help\
+ "index expression for last element"
+ } "@doc -name Manpage: -url [manpage_tcl lrange]"
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
lappend PUNKARGS [list {
@id -id ::lappend
@cmd -name "builtin: lappend" -help\
@@ -583,7 +654,9 @@ tcl::namespace::eval punk::args::tclcore {
"variable name"
value -type any -optional 1 -multiple 1
} "@doc -name Manpage: -url [manpage_tcl lappend]"]
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id ::ledit
@cmd -name "builtin: ledit" -help\
@@ -596,7 +669,9 @@ tcl::namespace::eval punk::args::tclcore {
last -type indexexpression
value -type any -optional 1 -multiple 1
} "@doc -name Manpage: -url [manpage_tcl ledit]"
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id ::lpop
@cmd -name "builtin: lpop" -help\
@@ -616,7 +691,7 @@ tcl::namespace::eval punk::args::tclcore {
previous indexing operation, allowing the script to remove elements
in sublists, similar to lindex and lset."
} "@doc -name Manpage: -url [manpage_tcl lpop]"
-
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id ::lrange
@cmd -name "builtin: lrange" -help\
@@ -635,8 +710,66 @@ tcl::namespace::eval punk::args::tclcore {
last -help\
"index expression for last element"
} "@doc -name Manpage: -url [manpage_tcl lrange]"
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ ############################################################################################################################################################
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ # COMMANDS M-Z
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ ############################################################################################################################################################
+
+
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ punk::args::define {
+ @id -id ::set
+ @cmd -name "builtin: set" -help\
+ "Read and write variables.
+
+ Returns the value of variable varName. If value is specified,
+ then set the value of varName to value, creating a new variable
+ if one does not already exist, and return its value. If varName
+ contains an open parenthesis and ends with a close parenthesis,
+ then it refers to an array element: the characters before the
+ first open parenthesis are the name of the array, and the
+ characters between the parentheses are the index within the array.
+ Otherwise varName refers to a scalar variable.
+ If varName includes namespace qualifiers (in the array name if it
+ refers to an array element), or if varName is unqualified (does
+ not include the names of any containing namespaces) but no
+ procedure is active, varName refers to a namespace variable
+ resolved according to the rules described under NAME RESOLUTION
+ in the namespace manual page.
+ If a procedure is active and varName is unqualified, then varName
+ refers to a parameter or local variable of the procedure, unless
+ varName was declared to resolve differently through one of the
+ global, variable, or upvar commands.
+ "
+ @values -min 1 -max 2
+ varName -type string -help\
+ "name of scalar or array variable
+ scalar variable e.g myvar
+ array element e.g myarray(identifier.x)
+ namespaced scalar variable e.g ::ns1::myvar
+ namespaced array element e.g ::ns1::myarray(subelement)
+ Nested datastructures may be simulated with an array by using
+ some programmer chosen convention to seperate levels.
+ e.g set myarray(config,0) \"val1\"
+ set myarray(config,1) \"etc\"
+ set myarray(data,0) {a b c}
+ see the dict command for an alternative datastructure.
+ "
+ value -type any -optional 1
+ } "@doc -name Manpage: -url [manpage_tcl set]"
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+
+
+
+
+
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id ::tcl::string::cat
@@ -982,6 +1115,38 @@ tcl::namespace::eval punk::args::tclcore {
string -type string -optional 0
}] "@doc -name Manpage: -url [manpage_tcl string]"
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+ punk::args::define {
+ @id -id ::variable
+ @cmd -name "builtin: variable" -help\
+ "Create and initialise a namespace variable.
+ "
+ @form -form "setvalues" -synopsis "variable ?name value...? ?name?"
+ @values -min 2 -max -1
+ #todo
+ #In this case - we don't want name_value to display - as this is only used for documenting a builtin
+ #For the case where an @argroups is used also for parsing - the help should display the synopsis form
+ #and also the name of the var in which it is placed.
+ # e.g
+ # ?{name value}...?
+ # (name_value)
+ #The second line giving an indication the resulting list of pairs can be accessed with something like:
+ # dict get $argd values name_value
+
+ #@arggroup -name name_value -min 1 -max 2 -optional 1 -multiple 1 -args {
+ # name
+ # value
+ # }
+
+ @form -form "declare" -synopsis "variable name"
+ @values -min 1 -max 1
+ name -optional 0
+
+ } "@doc -name Manpage: -url [manpage_tcl variable]"
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+
+
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id ::zlib
@cmd -name "builtin: ::zlib" -help\
@@ -1007,9 +1172,13 @@ tcl::namespace::eval punk::args::tclcore {
stream "zlib stream mode ?options?"
adler32 "zlib adler32 string ?initValue?"
crc32 "zlib crc32 string ?initValue?"
- }
+ }\
+ -choiceinfo {
+ adler32 {}
+ }
} "@doc -name Manpage: -url [manpage_tcl zlib]"
+
punk::args::define {
@id -id "::zlib adler32"
@cmd -name "builtin: ::zlib adler32" -help\
@@ -1020,6 +1189,7 @@ tcl::namespace::eval punk::args::tclcore {
string -type string
initValue -type string -optional 1
} "@doc -name Manpage: -url [manpage_tcl zlib]"
+ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
diff --git a/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.1.tm
index 353d1f65..1381af87 100644
--- a/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.1.tm
+++ b/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.1.tm
@@ -890,7 +890,7 @@ namespace eval punk::lib {
set cur [lmap a_l $list_l { lindex $a_l 0 }]
set list_l [lmap a_l $list_l { lrange $a_l 1 end }]
- if {[join $cur {}] == {}} {
+ if {[join $cur {}] eq {}} {
break
}
lappend zip_l $cur
diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm
index 6a1252f0..7d59eb35 100644
--- a/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm
+++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm
@@ -687,27 +687,36 @@ namespace eval punk::mix::cli {
package require punk::zip
set zipfile $buildfolder/$basename-$module_build_version.zip ;#ordinary zip file (deflate)
- if 0 {
- #use -base $buildfolder so that -directory is included in the archive - the modpod stub relies on this - and extraction would be potentially messy otherwise
- punk::zip::mkzip -base $buildfolder -directory $buildfolder/#modpod-$basename-$module_build_version -- $zipfile *
- #punk::zip::mkzip stores permissions - (unix style) which confuses zipfs when reading - it misidentifies dirs as files
- }
#zipfs mkzip does exactly what we need anyway in this case
#unfortunately it's not available in all Tclsh versions we might be running..
if {[llength [info commands zipfs]]} {
+ #zipfs mkzip (2025) doesn't add entries for folders.
+ #(Therefore no timestamps)
+ #zip reading utils generally intuit their existence and display them - but often an editor can't add comments to them
set wd [pwd]
cd $buildfolder
puts "zipfs mkzip $zipfile #modpod-$basename-$module_build_version"
zipfs mkzip $zipfile #modpod-$basename-$module_build_version
cd $wd
- package require modpod
- modpod::lib::make_zip_modpod $zipfile $modulefile
} else {
+ #use -base $buildfolder so that -directory is included in the archive - the modpod stub relies on this - and extraction would be potentially messy otherwise
+ #put in an archive-level comment to aid in debugging
+ #punk
+ punk::zip::mkzip -base $buildfolder -directory $buildfolder/#modpod-$basename-$module_build_version -- $zipfile *
+ #punk::zip::mkzip stores permissions - (unix style) - which zipfs mkzip doesn't
+ #Directory ident in zipfs relies on folders ending with trailing slash - if missing, it misidentifies dirs as files.
+ #(ie it can't use permissions/attributes alone to determine directory vs file)
#TODO - review punk::zip::mkzip and/or external zip to provide a fallback?
- set had_error 1
- lappend notes "zipfs_unavailable"
- puts stderr "WARNING: zipfs unavailable can't build $modulefile"
+ #JMN25
+
+ #set had_error 1
+ #lappend notes "zipfs_unavailable"
+ #puts stderr "WARNING: zipfs unavailable can't build $modulefile"
+ }
+ if {!$had_error && [file exists $zipfiles]} {
+ package require modpod
+ modpod::lib::make_zip_modpod $zipfile $modulefile
}
diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/doc-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/doc-0.1.0.tm
index 6b1923b1..fa9e8d7c 100644
--- a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/doc-0.1.0.tm
+++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/doc-0.1.0.tm
@@ -22,7 +22,7 @@ package require punk::path ;# for treefilenames, relative
package require punk::repo
package require punk::docgen ;#inline doctools - generate doctools .man files at src/docgen prior to using kettle to producing .html .md etc
package require punk::mix::cli ;#punk::mix::cli::lib used for kettle_call
-#package require punk::mix::util ;#for path_relative
+#package require punkcheck ;#for path_relative
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
diff --git a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm
index 6235224a..8fa9ce89 100644
--- a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm
+++ b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm
@@ -1995,7 +1995,7 @@ tcl::namespace::eval punk::ns {
-return -type string -default table -choices {string table tableobject}
- } {${[punk::args::get_spec ::punk::args::arg_error -scheme]}} {
+ } {${[punk::args::resolved_def -type @opts ::punk::args::arg_error -scheme]}} {
-- -type none -help\
"End of options marker
diff --git a/src/vfs/_vfscommon.vfs/modules/punk/packagepreference-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/packagepreference-0.1.0.tm
index 5f7dba71..03578a56 100644
--- a/src/vfs/_vfscommon.vfs/modules/punk/packagepreference-0.1.0.tm
+++ b/src/vfs/_vfscommon.vfs/modules/punk/packagepreference-0.1.0.tm
@@ -119,6 +119,7 @@ tcl::namespace::eval punk::packagepreference {
#*** !doctools
#[call [fun install]]
#[para]Override ::package builtin (or the current implementation if it has already been renamed/overridden) to check for and prefer lowercase packages/modules
+ #[para](todo - check info loaded and restrict to existing version as determined from dll/so?)
#[para]The overriding package command will call whatever implementation was in place before install to do the actual work - once it has modified 'package require' names to lowercase.
#[para]This is intended to be in alignment with tip 590 "Recommend lowercase Package Names"
#[para] https://core.tcl-lang.org/tips/doc/trunk/tip/590.md
@@ -152,40 +153,83 @@ tcl::namespace::eval punk::packagepreference {
#despite preference for lowercase - we need to handle packages that insist on providing as uppercase
#(e.g we will still need to handle things like: package provide Tcl 8.6)
#Where the package is already provided uppercase we shouldn't waste time deferring to lowercase
+ set is_exact 0
if {[lindex $args 1] eq "-exact"} {
set pkg [lindex $args 2]
- set vwant [lindex $args 3]
- if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} {
- #although we could shortcircuit using vsatisfies to return the ver
- #we should instead pass through to COMMANDSTACKNEXT so as not to interfere with whatever it does.
- return [$COMMANDSTACKNEXT {*}$args]
-
- #if {$vwant eq "" || [$COMMANDSTACKNEXT vsatisfies $ver $vwant]} {
- # return $ver
- #} else {
- # #package already provided with a different version.. we will defer to underlying implementation to return the standard error
- # return [$COMMANDSTACKNEXT {*}$args]
- #}
- }
+ set vwant [lindex $args 3]-[lindex $args 3]
+ set is_exact 1
} else {
set pkg [lindex $args 1]
- set vwant [lindex $args 2]
- if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} {
- return [$COMMANDSTACKNEXT {*}$args]
- #if {$vwant eq "" || [$COMMANDSTACKNEXT vsatisfies $ver $vwant]} {
- # return $ver
- #}
+ set vwant [lrange $args 2 end] ;#rare - but version can be a list of options
+ if {[llength $vwant] == 1 && [string first - [lindex $vwant 0]] > 0} {
+ #only one version - and it has a dash
+ lassign [split [lindex $vwant 0] -] a b
+ if {$a eq $b} {
+ #string compare version nums (can contain dots and a|b)
+ set is_exact 1
+ }
+ }
+ }
+ if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} {
+ #although we could shortcircuit using vsatisfies to return the ver
+ #we should instead pass through to COMMANDSTACKNEXT so as not to interfere with whatever it does.
+ #e.g a package require logger further down the commandstack
+ return [$COMMANDSTACKNEXT {*}$args]
+ }
+
+ if {!$is_exact && [llength $vwant] <= 1 } {
+ #required version unspecified - or specified singularly
+ # ---------------------------------------------------------------
+ #An attempt to detect dll/so loaded and try to load same version
+ set pkgloadedinfo [lsearch -inline -index 1 [info loaded] $pkg]
+ if {![llength $pkgloadedinfo]} {
+ if {[regexp {[A-Z]} $pkg]} {
+ set pkgloadedinfo [lsearch -inline -index 1 [info loaded] [string tolower $pkg]]
+ if {![llength $pkgloadedinfo]} {
+ set pkgloadedinfo [lsearch -inline -index 1 [info loaded] [string totitle $pkg]]
+ }
+ }
+ }
+
+ if {[llength $pkgloadedinfo]} {
+ puts stderr "--> pkg not present but shared object seems to be loaded: $pkgloadedinfo"
+ lassign $pkgloadedinfo path name
+ set lcpath [string tolower $path]
+ set obj [file tail $lcpath]
+ if {[string match tcl9* $obj]} {
+ set obj [string range $obj 4 end]
+ } elseif {[string match lib* $obj]} {
+ set obj [string range $obj 3 end]
+ }
+ set pkginfo [file rootname $obj]
+ #e.g Thread2.8.8
+ if {[regexp {^([a-zA-Z\-]+)(.*)} $pkginfo _match lname lversion]} {
+ if {[string tolower $lname] eq [string tolower $pkg]} {
+ #name matches pkg
+ #hack for known dll version mismatch
+ if {[string tolower $pkg] eq "thread" && $lversion eq "30b3"} {
+ set lversion 3.0b3
+ }
+ if {[llength $vwant] == 1} {
+ #todo - still check vsatisfies - report a conflict? review
+ }
+ return [$COMMANDSTACKNEXT require $pkg $lversion-$lversion]
+ }
+ }
}
}
+ # ---------------------------------------------------------------
+ set pkgloadedinfo [lsearch -inline -index 1 [info loaded] $pkg]
+
if {[regexp {[A-Z]} $pkg]} {
#only apply catch & retry if there was a cap - otherwise we'll double try for errors unrelated to capitalisation
- if {[catch {$COMMANDSTACKNEXT {*}[string tolower $args]} v]} {
- return [$COMMANDSTACKNEXT {*}$args]
+ if {[catch {$COMMANDSTACKNEXT require [string tolower $pkg] {*}$vwant} v]} {
+ return [$COMMANDSTACKNEXT require $pkg {*}$vwant]
} else {
return $v
}
} else {
- return [$COMMANDSTACKNEXT {*}$args]
+ return [$COMMANDSTACKNEXT require $pkg {*}$vwant]
}
}
default {
diff --git a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.tm
index 9859ed8e..63b82f02 100644
--- a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.tm
+++ b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.tm
@@ -2621,7 +2621,9 @@ namespace eval repl {
# }
#}
#puts stdout "===================="
-
+ package require punk::packagepreference
+ punk::packagepreference::install
+
package require punk::console
package require punk::repl::codethread
package require shellfilter
diff --git a/src/vfs/_vfscommon.vfs/modules/punk/repl/codethread-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/repl/codethread-0.1.1.tm
index b3693f71..6158fdce 100644
--- a/src/vfs/_vfscommon.vfs/modules/punk/repl/codethread-0.1.1.tm
+++ b/src/vfs/_vfscommon.vfs/modules/punk/repl/codethread-0.1.1.tm
@@ -137,6 +137,13 @@ tcl::namespace::eval punk::repl::codethread {
variable run_command_cache
+ #Use interp exists instead..
+ #if {[catch {interp children}]} {
+ # #8.6.10 doesn't have it.. when was it introduced?
+ #} else {
+
+ #}
+
proc is_running {} {
variable running
return $running
@@ -150,7 +157,7 @@ tcl::namespace::eval punk::repl::codethread {
#expecting to be called from a thread::send in parent repl - ie in the toplevel interp so that the sub-interp "code" is available
#if a thread::send is done from the commandline in a codethread - Tcl will
- if {"code" ni [interp children] || ![info exists replthread_cond]} {
+ if {![interp exists code] || ![info exists replthread_cond]} {
#in case someone tries calling from codethread directly - don't do anything or change any state
#(direct caller could create an interp named code at the level "" -> "code" -"code" and add a replthread_cond value to avoid this check - but it probably won't do anything useful)
#if called directly - the context will be within the first 'code' interp.
diff --git a/src/vfs/_vfscommon.vfs/modules/punk/safe-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/safe-0.1.0.tm
index 2b38dbb3..1c02675a 100644
--- a/src/vfs/_vfscommon.vfs/modules/punk/safe-0.1.0.tm
+++ b/src/vfs/_vfscommon.vfs/modules/punk/safe-0.1.0.tm
@@ -458,7 +458,7 @@ tcl::namespace::eval punk::safe {
# If we have exactly 2 arguments the semantic is a "configure get"
lassign $args child arg
- set spec_dict [punk::args::define [punk::args::get_spec punk::safe::interpIC]]
+ set spec_dict [punk::args::define [punk::args::rawdef punk::safe::interpIC]]
set opt_names [dict get $spec_dict opt_names]
CheckInterp $child
@@ -631,6 +631,17 @@ tcl::namespace::eval punk::safe {
SyncAccessPath $child
return $token
}
+
+ if {[catch {interp children}]} {
+ #8.6.10 doesn't have it.. when was it introduced?
+ proc interp_children {{i {}}} {
+ puts stderr "punk::safe 'interp children' subcommand not available"
+ }
+ } else {
+ proc interp_children {{i {}}} {
+ interp children {*}$i
+ }
+ }
# This procedure deletes a safe interpreter managed by Safe Tcl and cleans up
# associated state.
# - The command will also delete non-Safe-Base interpreters.
@@ -648,7 +659,7 @@ tcl::namespace::eval punk::safe {
# Base. To clean up properly, we call safe::interpDelete recursively on each
# Safe Base sub-interpreter, so each one is deleted cleanly and not by
# the automatic mechanism built into [interp delete].
- foreach sub [interp children $child] {
+ foreach sub [interp_children $child] {
if {[info exists ::punk::safe::system::[VarName [list $child $sub]]]} {
::punk::safe::interpDelete [list $child $sub]
}
@@ -762,7 +773,7 @@ tcl::namespace::eval punk::safe::system {
"::auto_path for the child"}
}
punk::args::define $OPTS
- set optlines [punk::args::get_spec punk::safe::OPTS -*]
+ set optlines [punk::args::resolved_def -type @opts punk::safe::OPTS -*]
set INTERPCREATE {
@id -id ::punk::safe::interpCreate
diff --git a/src/vfs/_vfscommon.vfs/modules/punk/zip-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/zip-0.1.1.tm
index 11ae9ab2..2895b024 100644
--- a/src/vfs/_vfscommon.vfs/modules/punk/zip-0.1.1.tm
+++ b/src/vfs/_vfscommon.vfs/modules/punk/zip-0.1.1.tm
@@ -179,26 +179,55 @@ tcl::namespace::eval punk::zip {
# punk::zip::walk -exclude {CVS/* *~.#*} library
#}]
+ #todo: -relative 0|1 flag?
set argd [punk::args::get_dict {
@id -id ::punk::zip::walk
- @cmd -name punk::zip::walk
+ @cmd -name punk::zip::walk -help\
+ "Walk the directory structure starting at base/<-subpath>
+ and return a list of the files and folders encountered.
+ Resulting paths are relative to base unless -resultrelative
+ is supplied.
+ Folder names will end with a trailing slash.
+ "
+ -resultrelative -optional 1 -help\
+ "Resulting paths are relative to this value.
+ Defaults to the value of base. If empty string
+ is given to -resultrelative the paths returned
+ are effectively absolute paths."
-excludes -default "" -help "list of glob expressions to match against files and exclude"
- -subpath -default ""
+ -subpath -default "" -help\
+ "May contain glob chars for folder elements"
@values -min 1 -max -1
base
fileglobs -default {*} -multiple 1
} $args]
set base [dict get $argd values base]
- set fileglobs [dict get $argd values fileglobs]
+ set fileglobs [dict get $argd values fileglobs]
set subpath [dict get $argd opts -subpath]
set excludes [dict get $argd opts -excludes]
+ set received [dict get $argd received]
set imatch [list]
foreach fg $fileglobs {
lappend imatch [file join $subpath $fg]
}
+ if {![dict exists $received -resultrelative]} {
+ set relto $base
+ set prefix ""
+ } else {
+ set relto [file normalize [dict get $argd opts -resultrelative]]
+ if {$relto ne ""} {
+ if {![Path_a_atorbelow_b $base $relto]} {
+ error "punk::zip::walk base must be at or below -resultrelative value (backtracking not currently supported)"
+ }
+ set prefix [Path_strip_alreadynormalized_prefixdepth $base $relto]
+ } else {
+ set prefix $base
+ }
+ }
+
set result {}
#set imatch [file join $subpath $match]
set files [glob -nocomplain -tails -types f -directory $base -- {*}$imatch]
@@ -210,7 +239,7 @@ tcl::namespace::eval punk::zip {
break
}
}
- if {!$excluded} {lappend result $file}
+ if {!$excluded} {lappend result [file join $prefix $file]}
}
foreach dir [glob -nocomplain -tails -types d -directory $base -- [file join $subpath *]] {
set subdir_entries [walk -subpath $dir -excludes $excludes $base {*}$fileglobs]
@@ -218,7 +247,7 @@ tcl::namespace::eval punk::zip {
#NOTE: trailing slash required for entries to be recognised as 'file type' = "directory"
#This is true for 2024 Tcl9 mounted zipfs at least. zip utilities such as 7zip seem(icon correct) to recognize dirs with or without trailing slash
#Although there are attributes on some systems to specify if entry is a directory - it appears trailing slash should always be used for folder names.
- set result [list {*}$result "$dir/" {*}$subdir_entries]
+ set result [list {*}$result "[file join $prefix $dir]/" {*}$subdir_entries]
}
}
return $result
@@ -554,7 +583,9 @@ tcl::namespace::eval punk::zip {
-comment -default ""\
-help "An optional comment for the archive"
-directory -default ""\
- -help "The new zip archive will scan for contents within this folder or current directory if not provided."
+ -help "The new zip archive will scan for contents within this folder or current directory if not provided.
+ Note that this will
+ "
-base -default ""\
-help "The new zip archive will be rooted in this directory if provided
it must be a parent of -directory or the same path as -directory"
@@ -605,6 +636,7 @@ tcl::namespace::eval punk::zip {
set base $opts(-directory)
set relpath ""
}
+ #will pick up intermediary folders as paths (ending with trailing slash)
set paths [walk -exclude $opts(-exclude) -subpath $relpath -- $base {*}[dict get $argd values globs]]
set norm_filename [file normalize $filename]
@@ -654,6 +686,8 @@ tcl::namespace::eval punk::zip {
}
}
} else {
+ #NOTE that we don't add intermediate folders when creating an archive without using the -directory flag!
+ #ie - only the exact *files* matching the glob are stored.
set paths [list]
set dir [pwd]
if {$opts(-base) ne ""} {
@@ -712,7 +746,7 @@ tcl::namespace::eval punk::zip {
if {$opts(-offsettype) eq "archive"} {
set dataStartOffset [tell $zf] ;#the overall file offset of the start of archive-data //JMN 2024
} else {
- set dataStartOffset 0 ;#offsets relative to file - the zipfs mkzip way :/
+ set dataStartOffset 0 ;#offsets relative to file - the (old) zipfs mkzip way :/
}
set count 0
diff --git a/src/vfs/_vfscommon.vfs/modules/shellthread-1.6.1.tm b/src/vfs/_vfscommon.vfs/modules/shellthread-1.6.1.tm
index 2670058d..f0d3ad8a 100644
--- a/src/vfs/_vfscommon.vfs/modules/shellthread-1.6.1.tm
+++ b/src/vfs/_vfscommon.vfs/modules/shellthread-1.6.1.tm
@@ -521,6 +521,9 @@ namespace eval shellthread::manager {
set ::auto_path [dict get $::settingsinfo auto_path]
}
+ package require punk::packagepreference
+ punk::packagepreference::install
+
package require Thread
package require shellthread
if {![catch {::shellthread::worker::init %tidcli% %ts_start% $::settingsinfo} errmsg]} {
diff --git a/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm b/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm
index 32450e55..56651d21 100644
--- a/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm
+++ b/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm
@@ -96,42 +96,60 @@ tcl::namespace::eval textblock {
variable use_hash ;#framecache
set use_hash none ;#slightly faster but uglier layout for viewing frame_cache display
- #if {![catch {package require sha1}]} {
- # set use_hash sha1
- #} elseif {![catch {package require md5}]} {
- # set use_hash md5
- #} else {
- # set use_hash none
- #}
- proc use_hash {args} {
- set choices [list none]
- set unavailable [list]
- set pkgs [package names]
- if {"md5" in $pkgs} {
- lappend choices md5
- } else {
- lappend unavailable md5
+ namespace eval argdoc {
+ proc hash_algorithm_choices_and_help {} {
+ set choices [list none]
+ set unavailable [list]
+ set unloaded [dict create]
+ set algorithm_packages {md5 sha1 sha256}
+ foreach p $algorithm_packages {
+ if {[package provide $p] eq ""} {
+ dict set unloaded $p ""
+ }
+ }
+ if {[dict size $unloaded]} {
+ set allpkgs [package names] ;#only retrieve once
+ foreach p $algorithm_packages {
+ if {[dict exists $unloaded $p]} {
+ #not loaded - but check if available
+ if {$p in $allpkgs} {
+ lappend choices $p
+ } else {
+ lappend unavailable $p
+ }
+ } else {
+ lappend choices $p
+ }
+ }
+ } else {
+ lappend choices {*}$algorithm_packages
+ set unavailable ""
+ }
+
+ set choicemsg ""
+ if {[llength $unavailable]} {
+ set choicemsg " (unavailable packages: $unavailable)"
+ }
+ #return $choices
+ return " -choices \{$choices\} -help {algorithm choice $choicemsg} "
}
- if {"sha1" in $pkgs} {
- lappend choices sha1
- } else {
- lappend unavailable sha1
- }
- set choicemsg ""
- if {[llength $unavailable]} {
- set choicemsg " (unavailable packages: $unavailable)"
- }
- set argd [punk::args::get_dict [tstr -return string {
- @id -id ::textblock::use_hash
- @cmd -name "textblock::use_hash" -help\
- "Hashing algorithm to use for framecache lookup.
- 'none' may be slightly faster but less compact
- when viewing textblock::framecache"
- @values -min 0 -max 1
- hash_algorithm -choices {${$choices}} -optional 1 -help\
- "algorithm choice ${$choicemsg}"
- }] $args]
+ }
+
+ # hash_algorithm -optional 1 -choices {${[::textblock::argdoc::hash_algorithm_choices]}} -help\
+ # "algorithm choice"
+
+ punk::args::define -dynamic 1 {
+ @id -id ::textblock::use_hash
+ @cmd -name "textblock::use_hash" -help\
+ "Hashing algorithm to use for framecache lookup.
+ 'none' may be slightly faster but less compact
+ when viewing textblock::framecache"
+ @values -min 0 -max 1
+ hash_algorithm -optional 1 ${[::textblock::argdoc::hash_algorithm_choices_and_help]}
+ }
+ proc use_hash {args} {
+ set argd [punk::args::get_by_id ::textblock::use_hash $args]
variable use_hash
if {![dict exists $argd received hash_algorithm]} {
return $use_hash
@@ -4367,6 +4385,15 @@ tcl::namespace::eval textblock {
"
-return -default table -choices {table tableobject}
+ -table -default "" -type string\
+ -help "existing table object to use"
+ -action -default "append" -choices {append replace}\
+ -help "row insertion method if existing -table is supplied
+ if append is chosen the new values will always start at the first column"
+ -title -type string -help\
+ "Title to display overlayed on top edge of table.
+ Will not be visible if -show_edge is false"
+ -titlealign -type string -choices {left centre right}
-frametype -default "light" -type dict -choices {${$FRAMETYPES}} -choicerestricted 0\
-help "frame type or dict for custom frame"
-show_edge -default "" -type boolean\
@@ -4377,10 +4404,21 @@ tcl::namespace::eval textblock {
-show_hseps -default "" -type boolean\
-help "Show horizontal table separators
(default 0 if no existing -table supplied)"
- -table -default "" -type string\
- -help "existing table object to use"
-colheaders -default "" -type list\
- -help "list of lists. list of column header values. Outer list must match number of columns"
+ -help {list of lists. list of column header values. Outer list must match number of columns.
+ A table
+ e.g single header row: -colheaders {{column_a} {column_b} {column_c}}
+ e.g 2 header rows: -colheaders {{column_a "nextrow test"} {column_b} {column_c}}
+ Note that each element of the outer list is itself a list so:
+ -colheaders {"column a" "column b" "column c"}
+ Is likely not the right format if it was intended to have a single header row where the
+ column titles contain spaces.
+ The correct syntax for that would be:
+ -colheaders {{"column a"} {"column b"} {"column c"}}
+ For spanning header cells - use 'set t [list_as_table -return tableobject ...]'
+ and then something like:
+ $t configure_header 1 -colspans {3 0 0}; $t print
+ }
-header -default "" -type list -multiple 1\
-help "Each supplied -header argument is a header row.
The number of values for each must be <= number of columns"
@@ -4388,9 +4426,6 @@ tcl::namespace::eval textblock {
-help "Whether to show a header row.
Omit for unspecified/automatic,
in which case it will display only if -headers list was supplied."
- -action -default "append" -choices {append replace}\
- -help "row insertion method if existing -table is supplied
- if append is chosen the new values will always start at the first column"
-columns -default "" -type integer\
-help "Number of table columns
Will default to 2 if not using an existing -table object"
@@ -4404,6 +4439,7 @@ tcl::namespace::eval textblock {
set argd [punk::args::get_by_id ::textblock::list_as_table $args]
set opts [dict get $argd opts]
+ set received [dict get $argd received]
set datalist [dict get $argd values datalist]
set existing_table [dict get $opts -table]
@@ -4560,6 +4596,12 @@ tcl::namespace::eval textblock {
}
$t add_row $row
}
+ if {"-title" in $received} {
+ $t configure -title [dict get $opts -title]
+ }
+ if {"-titlealign" in $received} {
+ $t configure -titlealign [dict get $opts -titlealign]
+ }
#puts stdout $rowdata
if {[tcl::dict::get $opts -return] eq "table"} {
set result [$t print]
@@ -5895,7 +5937,16 @@ tcl::namespace::eval textblock {
append out [textblock::join -- $punks $cpunks] \n
set 2frames_a [textblock::join -- [textblock::frame -checkargs 0 $cpunks] [textblock::frame -checkargs 0 $punks]]
append out $2frames_a \n
- set 2frames_b [textblock::join -- [textblock::frame -checkargs 0 -ansiborder $cyanb -title "plainpunks" $punks] [textblock::frame -checkargs 0 -ansiborder $greenb -title "fancypunks" $cpunks]]
+ set 2frames_b [textblock::join --\
+ [textblock::frame -checkargs 0 -ansiborder $cyanb\
+ -title "plainpunks" $punks]\
+ [textblock::frame -checkargs 0 -ansiborder $greenb\
+ -title "fancy"\
+ -titlealign right\
+ -subtitle "punks"\
+ -subtitlealign left\
+ $cpunks]\
+ ]
append out [textblock::frame -checkargs 0 -title "punks" $2frames_b\n$RST$2frames_a] \n
set punkdeck [overtype::right [overtype::left [textblock::frame -checkargs 0 -ansiborder [a+ green bold] -type heavy -title ${redb}PATTERN$RST -subtitle ${redb}PUNK$RST $prightair_cyanb] "$blueb\n\n\P\nU\nN\nK$RST"] "$blueb\n\nD\nE\nC\nK"]
set spantable [[spantest] print]
@@ -7503,20 +7554,41 @@ tcl::namespace::eval textblock {
@id -id ::textblock::frame_cache
@cmd -name textblock::frame_cache -help\
"Display or clear the frame cache."
- -action -default {} -choices {clear} -help\
- "Clear the textblock::frame_cache dictionary"
-pretty -default 1 -help\
- "Use 'pdict textblock::frame_cache */*' for prettier output"
- @values -min 0 -max 0
+ "Uses 'pdict textblock::frame_cache */*' for prettier output
+ Either way this is set, output requires long lines and may
+ still wrap in an ugly manner. Try 'textblock::use_cache md5'
+ to shorten the argument display and reduce wrapping.
+ "
+ @values -min 0 -max 1
+ action -default {display} -choices {clear size info display} -choicelabels {
+ clear "Clear the textblock::frame_cache dictionary."
+ } -help "Perform an action on the frame cache."
}
proc frame_cache {args} {
set argd [punk::args::get_by_id ::textblock::frame_cache $args]
- set action [dict get $argd opts -action]
-
- if {$action ni [list clear ""]} {
- error "frame_cache action '$action' not understood. Valid actions: clear"
- }
+ set action [dict get $argd values action]
variable frame_cache
+ switch -- $action {
+ clear {
+ set size [dict size $frame_cache]
+ set frame_cache [tcl::dict::create]
+ return "frame_cache cleared $size entries"
+ }
+ size {
+ return [dict size $frame_cache]
+ }
+ info {
+ return [dict info $frame_cache]
+ }
+ display {
+ #fall through
+ }
+ default {
+ #assert - unreachable - punk::args should have validated
+ error "frame_cache -action '$action' not understood. Valid actions: clear size info display"
+ }
+ }
if {[dict get $argd opts -pretty]} {
set out [pdict -chan none frame_cache */*]
} else {
@@ -7544,10 +7616,6 @@ tcl::namespace::eval textblock {
append out \n ;# frames used to build tables often have joins - keep a line in between for clarity
}
}
- if {$action eq "clear"} {
- set frame_cache [tcl::dict::create]
- append out \nCLEARED
- }
return $out
}
@@ -7608,9 +7676,11 @@ tcl::namespace::eval textblock {
May contain ANSI - no trailing reset required.
${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing
e.g 2: frame -title [a+ red underline]MyThing${[textblock::RST]}"
+ -titlealign -default "centre" -choices {left centre right}
-subtitle -default "" -type string -regexprefail {\n}\
-help "Frame subtitle placed on bottombar - no newlines
May contain Ansi - no trailing reset required."
+ -subtitlealign -default "centre" -choices {left centre right}
-width -default "" -type int\
-help "Width of resulting frame including borders.
If omitted or empty-string, the width will be determined automatically based on content."
@@ -7667,7 +7737,9 @@ tcl::namespace::eval textblock {
-boxmap {}\
-joins [list]\
-title ""\
+ -titlealign "centre"\
-subtitle ""\
+ -subtitlealign "centre"\
-width ""\
-height ""\
-ansiborder ""\
@@ -7710,7 +7782,7 @@ tcl::namespace::eval textblock {
set k2 [tcl::prefix::match -error "" $optnames $k]
switch -- $k2 {
-etabs - -type - -boxlimits - -boxmap - -joins
- - -title - -subtitle - -width - -height
+ - -title - -titlealign - -subtitle - -subtitlealign - -width - -height
- -ansiborder - -ansibase
- -blockalign - -textalign - -ellipsis
- -crm_mode
@@ -7879,6 +7951,10 @@ tcl::namespace::eval textblock {
package require sha1
set hash [sha1::sha1 [encoding convertto utf-8 $hashables]]
}
+ sha256 {
+ package require sha256
+ set hash [sha2::sha256 [encoding convertto utf-8 $hashables]]
+ }
md5 {
package require md5
if {[package vsatisfies [package present md5] 2- ] } {
@@ -7887,7 +7963,7 @@ tcl::namespace::eval textblock {
set hash [md5::md5 [encoding convertto utf-8 $hashables]]
}
}
- none {
+ default {
set hash $hashables
}
}
@@ -8246,12 +8322,24 @@ tcl::namespace::eval textblock {
}
if {$opt_title ne ""} {
- set topbar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $tbar $opt_title] ;#overtype supports gx0 on/off
+ set titlealign [dict get $opts -titlealign]
+ set titlealignfull [tcl::prefix::match -error "" {left centre right} $titlealign]
+ if {$titlealignfull ni {left centre right}} {
+ error "textblock::frame -titlealign must be one of {left centre right} or a unique prefix thereof. Received $titlealign"
+ }
+ #set topbar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $tbar $opt_title] ;#overtype supports gx0 on/off
+ set topbar [overtype::block -blockalign $titlealignfull -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 $tbar $opt_title] ;#overtype supports gx0 on/off
} else {
set topbar $tbar
}
if {$opt_subtitle ne ""} {
- set bottombar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $bbar $opt_subtitle] ;#overtype supports gx0 on/off
+ set titlealign [dict get $opts -subtitlealign]
+ set titlealignfull [tcl::prefix::match -error "" {left centre right} $titlealign]
+ if {$titlealignfull ni {left centre right}} {
+ error "textblock::frame -subtitlealign must be one of {left centre right} or a unique prefix thereof. Received $titlealign"
+ }
+ #set bottombar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $bbar $opt_subtitle] ;#overtype supports gx0 on/off
+ set bottombar [overtype::block -blockalign $titlealignfull -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 $bbar $opt_subtitle] ;#overtype supports gx0 on/off
} else {
set bottombar $bbar
}
diff --git a/src/vfs/_vfscommon.vfs/modules/zipper-0.12.tm b/src/vfs/_vfscommon.vfs/modules/zipper-0.12.tm
index 6bf5e87eacb2aef2c5a678ce61f5af937be974d7..080e7da9391e33c62e5e9c49bd5c3006ae2e5f48 100644
GIT binary patch
delta 1668
zcmV-~27CGTO!rK%*BJ@4nmt-fc8oQsli(Rd6}x2jc563vsf%+}In23)G{CHd#A=f{
z8XE%t^pjQ^+W~u%G8;kxRFicZivh2*0UQhg0g;mq9i)HMZ+5AGE+0Evzy?Vinh{l;
zG4hSkQ{c?4YN7T<R#)=qFUKFQUZb{fb_U`xYQR0G$vKxf!{Nl?Zc`&Ttbm^Vv6@lA
z-;adYi^m1?Chrn*w*sK<S&=`bZrwWf3v2*P6fi)l$LGXwI1kYbN%mCn6gkSvm0UM-
zAZtC@QYU{BV`GB|n`?Abw}my*E5P~gJ92jqULNMZ8#sp{xED;ZDg85+UOJ*v*kr+q
z<pdDJ9&=<?!#R=@_aoBTsi9Cojafxg+qxLTz|T0M=u@P}6r{nEeu<g3{G^FI4Jvlo
zl8THHl?cF>FX6enJEW8hg@;45&oTmNSAV>9M3;Y`r`UpFE`i<Oe81mUgjZv6sdtCH
zqRi&E<F&H=lkLA2iO~`y2oGC<eR?QC^3b*rGc+9NKiVl`HVt9PAX-XNm$%lGwyZ*;
zvPYnBxrlUN3j!KB(XhBd3NKh7{F%n<H~*y53Y${|?;_Rca{z~5TCT1~68KA_8o+@z
zSc-qu_>C*U+%55KlVgQpNtZeu{M-A#<}0F`8zym+DlT{{b>ld?yzC0Fl&ukUJXe@2
zDfyTy@nia-qF+`V)bpAXFq#mYV-z2m?#UjWP-n~C?|#1SUH1vP>fUwx-QLA`(5)uY
z1$R4n!EX&+Id(PA?*~r}F0HjO7h2Q1pJ{*7qdxV!$QAstrR$1XaCwsIZ1{MU-0X3r
zdDTRLKa!w!2yB?NQ111gQB6N1NnWjT{dlR7-Pv$ErgC{5?i(iYDfe#h#*CyXtk>4$
zMw%-$d^e01hl%-udbKcq;O$+t8>`<`m-+QI>dddYM!myMxvO8B4)>%aC?oYzv}=Da
zj%)5;*t359%a4|-xO>mI-StM9Ak_;F)BQv`d{OnT_QqcIt!>uW8Nu}j7lT2;b;d&h
zdu7nB4SsE$SYv5BMC0w&hpX1vemGZE@O7F=#!<;hObk=d7s~so{QxtY;_=_^vx2ma
zCul}A@;}n*gio|cVq!z*>kke9Y`=d^!YeC3u3r))v>YJ&5%MfrnGF394w`xLZKG#;
z{P(w4yCj>I?a-A7_mZCD`vv|E_PNP!WHo}q1e!iv(EtuwHc}(1(Q<)h&Eqwx?g6{s
zW%u<%@?!KqN3wbH{|sfX5M%QtA#Jx+0{inyS-I-rFSg1{75dSpSX7oL*KB`y6qbwb
z6D};&7C*<o1P3!7+QG}X;8*K(>05H3Yby7mP_8KU3A}5cPQP5A-BF#j=w|0p-fitW
z@bJLU9(Ojv>EHo}9ZuG@JXybe+^SU+3$%9bv4^~aN1g*Go^O2MsBZ}NJo~dVMZWG&
z8tjTZ->_JIO=NvRyYUVD_FI4YY}GmQF*a?Q$CVoyklvsNu8Vh6cULyUFv=}z?Naj2
z#}#+^E4Z!2b64@w`s`>I2kiadP>6Hc&e*H$=<s=_l%v`m<BXA#tjT-l9k!{<gqF3?
zt`RFYju0EET4}W|$$$Tk*Kdd;&*!$9bKc<ksm*y$yMtOYeZVXF)+>LkPYmekR{YHq
zeY;PV+S@_et!TzgWvs@W?V(;dVoH0U?zBOJu(+LOsE8vu#k(8p4>Bif#R>5vnK-wY
z!f|;|W5t8%bQv2vkjyiA<S*l3#`91+uATchde~O2iNH^%tFG|RQ^Z`(<o5TO&O;hX
zlb-n+4qz9{nb!_Z``v&31#B%xYd2S)s#u}m+0hNR`<af<?W8_G?dQJ}rRujOPC|CO
z^FGV>#f!>}beJqyy7XQK`fI0VNx>S;l^uPZTMt{$811GE3tlqfLCJ2Ig}f16$(>zO
z4ciLo)Q_jit>_WFyBS~;EHm6o4yREv=Gi6>Ln2nX)!nZNzIuNlJsgcjJFU5xLl$Wx
zf4oU!qG0_=W|W)%T%SL-!^!GovWj~WI(>msW5L&qg!3ymP%%yfnj!ygAwy{=vK_AN
zgMfNzRBgH~(NT<Xa&2(sKA?=e5{Xf~x*B$8BF?KU*I|x5PrlBTY^=HF*aDCn=W?S~
zxeDn>1+<Limyr)uvBJ`^GZPi5tk{c~{R6YKBN+k-w3<CyOm>VlsFT(uWdi64lh7k0
OlVBzg2K5U70001h9a5(N
delta 1679
zcmV;A25|ZJO!iE$*BJ@@V`N#zOykO@li(Rd729O@c563vsf%+}In23)G{CHd#A%Z`
z8XE%r{F7E1+W`lYG8;kxT$6Phive%50UQhg0g00i9i)F=zO+jPbotoX0yaqE(2S_!
zjFE4Qo&slXRSUH@vbvH-e>whe^%}K>vojEnQ3LKdP0qQ@84f27cbgi)VFmQ;kJXF{
z{(dCHUOX<CH+h$kyA=R+&x-shb?er-Utj}ZqJRNXJw7Lf!+D5iNV2Djr^r!WuH?Fz
z16k|ImO6it7#kZz*j%Hdx-G1cUIET`-;uj}@bWPK-M~2v!M$LLP3fPp^wJTX!X^t=
zEGK{%_Lw8H8qSfNxF3<uP7Q?$YRoE{+SbJw27bm7MV}%)rXUTT^h?aN<tI(#X;87t
zmQ-Yvs6+t5GrNr)Qc8xx!y(#d83DAbKi)c`%g=vPY{4*>!0vCp-|s8JtFgG$yTe{l
zX7k(eTG{@|_Fs#{XbBR8hpoUqJ(M7MXj_OG8V>Xy?G!PahOlH1EhVYTTWd;NRv}T@
zBT%?pL^`kq0gaq!Sll3m7c3C|Oyl*Nf6!@#%_)L+k!tigfWt2>SJxv6{H0M1;6NKJ
z#cF^2#+6|1miV^GvBI#VOPvn>?fqZ#717NNlekG07rd3aaU5M<b_H0<)`&WuE6kOY
ze9V>jG5uK4FDnk}dCdtJO$g30ijPe9WDifMv*qr0zg+jO`vhHe@4EeN?_xaYRuk!h
zyPdq?w}!49yPD_sgQo_U*4mg0t?At_wCR6QpZZ<o3jWyAbww?>JV|vne7s6-_BhhK
zYNEg&Nl-fkHcVP5_xjJMrk{}{uU5H!ywu3<Y`7g$xx5bd4U_nkdpCGvM$#14Yin{N
z%@rEH8%B%6#C$=$S{Og@_O9BE)o-fH{Q4So=2u;#-eITQ)vry5dr}gVk@_gwwHJTK
zHTN&<S-<}2M@v=Qy=UC+dZSE`>IH}Cej**dsCrj>W3T$wHf!vR;QE7$!Jyze<Dr1P
zGHBNZzcx;+v9ukc@pkLORqJd&oU1DMI?W{GsN^IjhAHR^<^9xtgqcn8`1|{;Ag$vG
znh}lskF+}B6D^XM*wFd<g98BDZ<BxU%F2)H*8~YI2grVeJd0K)LqCLrW}bZ8=$Rh>
z?d{br$);sHbS1*Qr04j4fxm-&Zn7I$ji4}rrVm#%fP<Ee)QD=dTwq!AculH%!0vb1
zef^NU82!(YY@Yl-L)k0D*nCMy+ijJ={=8CFu6p>Zt@2WZezGYRmF3Ab8y<g!<)Zt9
z3k$Wy&+#w8!HkD?@G>s=)jD1JmK^As%DpI*D~f#r@7kx+FV|;xRA()^*?E+ATl)??
zJTSD!osDohc)($YlXWdm)^8uTY8Ax-t(|-9A@AUk=fH{Q8y`688-hL0{_ISVulth*
zyCTmwES6srSzpj@d;`DzmOg)5b<TW@O`GO%<wgdiH|T-u;vLo9mCZ1Wa*JBKl)UqC
z#a;diZfo(}RlKx5JKDtod;d2S;#{^f_9{C%e4Z)gsCLIVW27W&^4@ueZR#?iWi7O8
z#LA5$#73%CTCGd+Km7gm8{)|Gxvl1$H@JRkbKcYLpw>(u@QS|m3hRFp1A4j@fAd7&
z?vthVc93=}nsHMZt1)MLs8^1d(jKTgZO|YrZl@V4;z&;M?#B9q%*k4DLi|W3&Ml^J
zT;9`I@nAY##>NgL^GqK3%Q%?vJk*YB=RS@ewpD8)@YCt4EBx~mF_$yB{e7nMkcQHv
zXTF95*u`?@wS&`sw|{>DTg%bf&DEzWRw#IObi?g_rsH!vsn1XQ`R_!j`p*(4A-mmq
zpXK}FMP)`hOcpF%dM^Y0wNtaCV2$R=j=s*VhplIfc2kB0FB$QmWH-!0-iWT`&aSD3
zZH08|$5Z82^a$SF46q578SW*A(<mA9Y?Fr}5i8y5?zaSAy^wz%jz*)M)?CaXi?oqH
z-lQ>6u>K@7%FVy8&mY_2WOXuG#XSj~zCfw5;A=+0`IQ@}7$*YFkbk$3p|lg(4%hZU
zK)p1oHr<x!D8@LsHn?&hP)1&f#3)`}4ZAZD=T(;LFvp%JU*}3T)?9OJ0mzMWxlyZJ
zg><9>TE_Cr$f^!lVd>bJiHcNK>_yD}0kgFu83GCYV`N#zOykO@lh-9>0_O>n(IX=k
ZP)h{{000000ssO4p8x;=^a}t0004mSVxIs2