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

update bootsupport + vfs: punk::lib 0.3.1, punk::args 0.3.2 (Tcl 9.1 compat); bootsupport catches up punk 0.2.3, punk::ns 0.1.2 

Batched make.tcl modules/bootsupport/vfscommonupdate build outputs:
- _vfscommon.vfs modules: punk::lib 0.3.0->0.3.1, punk::args 0.3.1->0.3.2
- src/bootsupport/modules (and the project_layouts bootsupport copies):
  punk::lib 0.3.0->0.3.1, punk::args 0.2.3->0.3.2, plus catch-up to the
  already-committed punk 0.2.1->0.2.3 and punk::ns 0.1.1->0.1.2

Assisted-by: harness=claude; primary-model=claude-fable-5; api-location=anthropic.com
master
Julian Noble 6 days ago
parent
6d8228c2f8
commit
6543132aba
14 changed files with 1163 additions and 462 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 78
      src/bootsupport/modules/punk-0.2.3.tm
  2. 9
      src/bootsupport/modules/punk/args-0.3.2.tm
  3. 38
      src/bootsupport/modules/punk/lib-0.3.1.tm
  4. 28
      src/bootsupport/modules/punk/ns-0.1.2.tm
  5. 78
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.2.3.tm
  6. 382
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.3.2.tm
  7. 38
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.3.1.tm
  8. 28
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.2.tm
  9. 78
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.2.3.tm
  10. 382
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.3.2.tm
  11. 38
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.3.1.tm
  12. 28
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.2.tm
  13. 382
      src/vfs/_vfscommon.vfs/modules/punk/args-0.3.2.tm
  14. 38
      src/vfs/_vfscommon.vfs/modules/punk/lib-0.3.1.tm

78
src/bootsupport/modules/punk-0.2.1.tm → src/bootsupport/modules/punk-0.2.3.tm
Unescape View File

@ -8464,35 +8464,56 @@ namespace eval punk {
#(re)generate the punk::args definitions for ::punk::help and ::punk::help_chunks from the registry
#so that 'i help' shows a documented topic table matching the registered topics.
#minimum-prefix policy for topic words (user decision 2026-07-08):
# - prefixes of the 'help' alias are denied: h/he/hel stay available as command
# words ('help' itself must be typed in full)
# - c, to and tc are reserved phantoms so they fall through to command lookup
# (co.../top.../full 'tcl' still match; e/en and te/ter fall through naturally
# as ambiguous prefixes of env|environment and term|terminal)
variable topic_prefixdenylist {help}
variable topic_prefixreservelist {c to tc}
proc define_docs {} {
variable topics
variable topic_prefixdenylist
variable topic_prefixreservelist
#G-040: canonical topic names are the choices; registry aliases become
#-choicealiases (accepted + normalized at parse, folded into the canonical
#entry in usage display). choiceinfo/choicelabels key on canonicals only.
set choices [list]
set choicealiases [dict create]
set choiceinfo [dict create]
set choicelabels [dict create]
dict for {topic tinfo} $topics {
foreach name [list $topic {*}[dict get $tinfo aliases]] {
lappend choices $name
dict set choiceinfo $name [list [list doctype punkargs] [list subhelp [namespace current]::$topic]]
dict set choicelabels $name [dict get $tinfo summary]
lappend choices $topic
dict set choiceinfo $topic [list [list doctype punkargs] [list subhelp [namespace current]::$topic]]
dict set choicelabels $topic [dict get $tinfo summary]
foreach al [dict get $tinfo aliases] {
dict set choicealiases $al $topic
}
}
#keep help-text lines manually folded (~70 cols) - the usage tables don't yet
#wrap to terminal width, so line lengths here directly set the table width
set basehelp {Help system for the punk shell.
With no arguments - an overview of some key shell commands is displayed.
When the first argument is a recognised topic - help for that topic is displayed.
With no arguments - an overview of some key shell
commands is displayed.
When the first argument is a recognised topic - help
for that topic is displayed.
('help topics' lists the available topics)
Anything else is treated as a command name - basic command info (type and
synopsis) is shown for a resolvable command, or the resolved path for an
Anything else is treated as a command name - basic
command info (type and synopsis) is shown for a
resolvable command, or the resolved path for an
external executable.}
set topichelp {Help topic, or command words for basic command info. (topics must match exactly - no prefix matching)}
set topichelp "Help topic, or command words for basic command info.\nTopics accept their aliases and unique prefixes\n(some short words deliberately fall through to command lookup)."
set specs [list]
lappend specs ::punk::help help "Punk shell help system." ""
lappend specs ::punk::help_chunks punk::help_chunks "Punk shell help system - content as {channel text} chunks." "\n\nhelp_chunks returns the help content as a list of {channel text} chunks rather than emitting it."
lappend specs ::punk::help_chunks punk::help_chunks "Punk shell help system - content as {channel text} chunks." "\n\nhelp_chunks returns the help content as a list of\n{channel text} chunks rather than emitting it."
foreach {id name summary extra} $specs {
set def ""
append def "@id -id $id" \n
append def "@cmd -name $name -summary \"$summary\" -help \"$basehelp$extra\"" \n
append def "@leaders -min 0 -max -1" \n
append def "topic -optional 1 -multiple 1 -type string -choiceprefix 0 -choicerestricted 0 -choices {$choices} -choiceinfo {$choiceinfo} -choicelabels {$choicelabels} -help \"$topichelp\"" \n
append def "topic -optional 1 -multiple 1 -type string -choiceprefix 1 -choicerestricted 0 -choicecolumns 2 -choices {$choices} -choicealiases {$choicealiases} -choiceprefixdenylist {$topic_prefixdenylist} -choiceprefixreservelist {$topic_prefixreservelist} -choiceinfo {$choiceinfo} -choicelabels {$choicelabels} -help \"$topichelp\"" \n
append def "@values -min 0 -max 0"
if {[punk::args::id_exists $id]} {
#quiet undefine - redefinition on registry change is expected, not noteworthy
@ -8548,7 +8569,12 @@ namespace eval punk {
punk::args::define {
@id -id ::punk::helptopic::topics
@cmd -name "help topics" -summary "List help topics." -help "Show the table of topics known to the help system, including registered aliases for each topic."
@cmd -name "help topics"\
-summary\
"List help topics."\
-help\
"Show the table of topics known to the help system,
including registered aliases for each topic."
@values -min 0 -max 0
}
proc topics {context args} {
@ -8570,7 +8596,15 @@ namespace eval punk {
punk::args::define {
@id -id ::punk::helptopic::tcl
@cmd -name "help tcl" -summary "Tcl version warnings." -help "Show the running Tcl patchlevel and build-info, with warnings for known Tcl bugs affecting this interpreter and known bugs in bundled library packages (as detected by the punk::lib::check::has_tclbug_* and has_libbug_* checks)."
@cmd -name "help tcl"\
-summary\
"Tcl version warnings."\
-help\
"Show the running Tcl patchlevel and build-info, with
warnings for known Tcl bugs affecting this interpreter
and known bugs in bundled library packages
(as detected by the punk::lib::check::has_tclbug_*
and has_libbug_* checks)."
@values -min 0 -max 0
}
proc tcl {context args} {
@ -8629,7 +8663,12 @@ namespace eval punk {
punk::args::define {
@id -id ::punk::helptopic::env
@cmd -name "help env" -summary "punkshell environment vars." -help "Show punk-related and other relevant environment variables with their current values."
@cmd -name "help env"\
-summary\
"punkshell environment vars."\
-help\
"Show punk-related and other relevant environment
variables with their current values."
@values -min 0 -max 0
}
proc env {context args} {
@ -8730,7 +8769,14 @@ namespace eval punk {
punk::args::define {
@id -id ::punk::helptopic::console
@cmd -name "help console" -summary "Console behaviour tests and warnings." -help "Run some console/terminal behaviour tests (control string hiding, grapheme cluster support, cursor position query timing) and report warnings. Requires a responsive interactive console."
@cmd -name "help console"\
-summary\
"Console behaviour tests and warnings."\
-help\
"Run some console/terminal behaviour tests (control
string hiding, grapheme cluster support, cursor
position query timing) and report warnings.
Requires a responsive interactive console."
@values -min 0 -max 0
}
proc console {context args} {
@ -9357,7 +9403,7 @@ punkcheck::cli set_alias punkcheck
package provide punk [namespace eval punk {
#FUNCTL
variable version
set version 0.2.1
set version 0.2.3
}]

9
src/vfs/_vfscommon.vfs/modules/punk/args-0.3.1.tm → src/bootsupport/modules/punk/args-0.3.2.tm
Unescape View File

@ -8,7 +8,7 @@
# (C) 2024
#
# @@ Meta Begin
# Application punk::args 0.3.1
# Application punk::args 0.3.2
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
@ -18,7 +18,7 @@
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin punkshell_module_punk::args 0 0.3.1]
#[manpage_begin punkshell_module_punk::args 0 0.3.2]
#[copyright "2024"]
#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}]
#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}]
@ -11590,7 +11590,8 @@ tcl::namespace::eval punk::args::lib {
#The internal rep can be an 'arithseries' with no string representation
proc zero_based_posns {count} {
if {$count < 1} {return}
lseq 0 $count-1
#expr wrapper required: lseq in Tcl 9.1+ (TIP 746) no longer evaluates expression operands
lseq 0 [expr {$count-1}]
}
} else {
proc zero_based_posns {count} {
@ -12550,7 +12551,7 @@ package provide punk::args [tcl::namespace::eval punk::args {
tcl::namespace::path {::punk::args::lib ::punk::args::system}
variable pkg punk::args
variable version
set version 0.3.1
set version 0.3.2
}]
return

38
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.3.0.tm → src/bootsupport/modules/punk/lib-0.3.1.tm
Unescape View File

@ -8,7 +8,7 @@
# (C) 2024
#
# @@ Meta Begin
# Application punk::lib 0.3.0
# Application punk::lib 0.3.1
# Meta platform tcl
# Meta license BSD
# @@ Meta End
@ -18,7 +18,7 @@
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin punkshell_module_punk::lib 0 0.3.0]
#[manpage_begin punkshell_module_punk::lib 0 0.3.1]
#[copyright "2024"]
#[titledesc {punk general utility functions}] [comment {-- Name section and table of contents description --}]
#[moddesc {punk library}] [comment {-- Description at end of page heading --}]
@ -320,7 +320,10 @@ tcl::namespace::eval punk::lib::check {
interp create x -safe
} errMsg]} {
x eval {proc ensembletest {} {string index a 0}}
set bytecode_safe [x eval {tcl::unsupported::disassemble proc ::ensembletest}]
if {[catch {x eval {tcl::unsupported::disassemble proc ::ensembletest}} bytecode_safe]} {
#Tcl 9.1+ removes tcl::unsupported::* from safe interps - disassemble is instead a hidden command (tcl:unsupported:disassemble)
set bytecode_safe [interp invokehidden x tcl:unsupported:disassemble proc ::ensembletest]
}
if {$show} {
puts safe:
puts $bytecode_safe
@ -1311,14 +1314,27 @@ namespace eval punk::lib {
#tcl 8.7+ lseq significantly faster, especially for larger ranges
#The internal rep can be an 'arithseries' with no string representation
#support minimal set from to
proc range {from to {by 1}} {
proc range {from to {by ""}} {
#note inconsistency with lseq 1 10 by -9 vs lseq 1 10 by -10
#https://core.tcl-lang.org/tcl/tktview/999b6966b2
#lseq in Tcl 9.1+ no longer evaluates expression operands such as 4-1 (TIP 746)
#range continues to accept int[+-]int offset forms e.g `range 0 [llength $list]-1` (same contract as the non-lseq fallback below)
if {![string is double -strict $from]} {set from [offset_expr $from]}
if {![string is double -strict $to]} {set to [offset_expr $to]}
if {$by eq ""} {
#direction inferred - lseq produces a descending sequence when from > to (matching the non-lseq fallback below)
return [lseq $from $to]
}
if {![string is double -strict $by]} {set by [offset_expr $by]}
if {$by == 0} {
#documented range behaviour (and lseq behaviour prior to Tcl 9.1): a step of zero produces no results
return [list]
}
lseq $from $to by $by
}
} else {
#lseq accepts basic expressions e.g 4-2 for both arguments
#e.g we can do lseq 0 [llength $list]-1
#lseq prior to Tcl 9.1 (TIP 746) accepted basic expressions e.g 4-2 for both arguments
#range accepts int[+-]int offset forms in all branches e.g we can do range 0 [llength $list]-1
#if range is to be consistent with the lseq version above - it should support that, even though we don't support most lseq functionality in either wrapper.
#our range function doesn't support double like lseq does. (deliberate) review
proc range {from to {by ""}} {
@ -1595,7 +1611,7 @@ namespace eval punk::lib {
foreach len $lens list $args {
lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""]
}
lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *}
lmap c [lseq 0 [expr {$numcolumns-1}]] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *}
}
proc lzipn_tcl9c {args} {
#SLOW
@ -1614,7 +1630,7 @@ namespace eval punk::lib {
}
lappend zip_l [lsearch -stride $cols_remaining -index 0 -inline -all -subindices $flatlist *]
set flen [llength $flatlist]
set flatlist [lremove $flatlist {*}[lseq 0 to $flen-1 by $cols_remaining]]
set flatlist [lremove $flatlist {*}[lseq 0 to [expr {$flen-1}] by $cols_remaining]]
incr cols_remaining -1
}
return $zip_l
@ -8613,14 +8629,14 @@ tcl::namespace::eval punk::lib::flatgrid {
}
proc cols {list numcolumns {blank NULL}} {
set cols [list]
foreach colindex [lseq 0 $numcolumns-1] {
foreach colindex [lseq 0 [expr {$numcolumns-1}]] {
lappend cols [lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] *]
}
return $cols
}
proc cols2 {list numcolumns {blank NULL}} {
set cols [list]
foreach colindex [lseq 0 $numcolumns-1] {
foreach colindex [lseq 0 [expr {$numcolumns-1}]] {
lappend cols [col2 $list $numcolumns $colindex $blank]
}
return $cols
@ -9119,7 +9135,7 @@ namespace eval ::punk::args::register {
package provide punk::lib [tcl::namespace::eval punk::lib {
variable pkg punk::lib
variable version
set version 0.3.0
set version 0.3.1
}]
return

28
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.1.tm → src/bootsupport/modules/punk/ns-0.1.2.tm
Unescape View File

@ -7,7 +7,7 @@
# (C) 2023
#
# @@ Meta Begin
# Application punk::ns 0.1.1
# Application punk::ns 0.1.2
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
@ -5154,16 +5154,26 @@ y" {return quirkykeyscript}
return [list 3 $origin $resolvedargs [list {*}$eparams {*}$queryargs_untested] $docid]
break
}
set resolved_q [tcl::prefix::match -error "" $allchoices $q]
if {$resolved_q eq ""} {
#G-040: resolve the subcommand word with the same shared resolver argument
#parsing uses (punk::args::choiceword_match) - so aliases normalize to their
#canonical (choiceinfo is keyed on canonicals), -choiceprefixdenylist and
#-choiceprefixreservelist are honoured, and 'i <cmd> <word>' can never accept
#a word that parsing would reject.
set ct_matchinfo [punk::args::choiceword_match $q\
[punk::args::system::Dict_getdef $arginfo -nocase 0]\
$allchoices\
[punk::args::system::Dict_getdef $arginfo -choicealiases {}]\
[dict get $arginfo -choiceprefix]\
[punk::args::system::Dict_getdef $arginfo -choiceprefixdenylist {}]\
[punk::args::system::Dict_getdef $arginfo -choiceprefixreservelist {}]\
]
if {![dict get $ct_matchinfo matched]} {
#no match under parse rules (covers: unknown word, ambiguous prefix,
#reserved word, denied prefix, and non-exact word when -choiceprefix 0)
return [list 4 $origin $resolvedargs $queryargs_untested $docid]
break
}
if {![dict get $arginfo -choiceprefix] && $resolved_q ne $q} {
#a unique prefix is not sufficient for this arg
return [list 5 $origin $resolvedargs $queryargs_untested $docid]
break
}
set resolved_q [dict get $ct_matchinfo canonical]
#if {$resolved_q ne $q} {
@ -7591,6 +7601,6 @@ namespace eval ::punk::args::register {
## Ready
package provide punk::ns [tcl::namespace::eval punk::ns {
variable version
set version 0.1.1
set version 0.1.2
}]
return

78
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.2.1.tm → src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.2.3.tm
Unescape View File

@ -8464,35 +8464,56 @@ namespace eval punk {
#(re)generate the punk::args definitions for ::punk::help and ::punk::help_chunks from the registry
#so that 'i help' shows a documented topic table matching the registered topics.
#minimum-prefix policy for topic words (user decision 2026-07-08):
# - prefixes of the 'help' alias are denied: h/he/hel stay available as command
# words ('help' itself must be typed in full)
# - c, to and tc are reserved phantoms so they fall through to command lookup
# (co.../top.../full 'tcl' still match; e/en and te/ter fall through naturally
# as ambiguous prefixes of env|environment and term|terminal)
variable topic_prefixdenylist {help}
variable topic_prefixreservelist {c to tc}
proc define_docs {} {
variable topics
variable topic_prefixdenylist
variable topic_prefixreservelist
#G-040: canonical topic names are the choices; registry aliases become
#-choicealiases (accepted + normalized at parse, folded into the canonical
#entry in usage display). choiceinfo/choicelabels key on canonicals only.
set choices [list]
set choicealiases [dict create]
set choiceinfo [dict create]
set choicelabels [dict create]
dict for {topic tinfo} $topics {
foreach name [list $topic {*}[dict get $tinfo aliases]] {
lappend choices $name
dict set choiceinfo $name [list [list doctype punkargs] [list subhelp [namespace current]::$topic]]
dict set choicelabels $name [dict get $tinfo summary]
lappend choices $topic
dict set choiceinfo $topic [list [list doctype punkargs] [list subhelp [namespace current]::$topic]]
dict set choicelabels $topic [dict get $tinfo summary]
foreach al [dict get $tinfo aliases] {
dict set choicealiases $al $topic
}
}
#keep help-text lines manually folded (~70 cols) - the usage tables don't yet
#wrap to terminal width, so line lengths here directly set the table width
set basehelp {Help system for the punk shell.
With no arguments - an overview of some key shell commands is displayed.
When the first argument is a recognised topic - help for that topic is displayed.
With no arguments - an overview of some key shell
commands is displayed.
When the first argument is a recognised topic - help
for that topic is displayed.
('help topics' lists the available topics)
Anything else is treated as a command name - basic command info (type and
synopsis) is shown for a resolvable command, or the resolved path for an
Anything else is treated as a command name - basic
command info (type and synopsis) is shown for a
resolvable command, or the resolved path for an
external executable.}
set topichelp {Help topic, or command words for basic command info. (topics must match exactly - no prefix matching)}
set topichelp "Help topic, or command words for basic command info.\nTopics accept their aliases and unique prefixes\n(some short words deliberately fall through to command lookup)."
set specs [list]
lappend specs ::punk::help help "Punk shell help system." ""
lappend specs ::punk::help_chunks punk::help_chunks "Punk shell help system - content as {channel text} chunks." "\n\nhelp_chunks returns the help content as a list of {channel text} chunks rather than emitting it."
lappend specs ::punk::help_chunks punk::help_chunks "Punk shell help system - content as {channel text} chunks." "\n\nhelp_chunks returns the help content as a list of\n{channel text} chunks rather than emitting it."
foreach {id name summary extra} $specs {
set def ""
append def "@id -id $id" \n
append def "@cmd -name $name -summary \"$summary\" -help \"$basehelp$extra\"" \n
append def "@leaders -min 0 -max -1" \n
append def "topic -optional 1 -multiple 1 -type string -choiceprefix 0 -choicerestricted 0 -choices {$choices} -choiceinfo {$choiceinfo} -choicelabels {$choicelabels} -help \"$topichelp\"" \n
append def "topic -optional 1 -multiple 1 -type string -choiceprefix 1 -choicerestricted 0 -choicecolumns 2 -choices {$choices} -choicealiases {$choicealiases} -choiceprefixdenylist {$topic_prefixdenylist} -choiceprefixreservelist {$topic_prefixreservelist} -choiceinfo {$choiceinfo} -choicelabels {$choicelabels} -help \"$topichelp\"" \n
append def "@values -min 0 -max 0"
if {[punk::args::id_exists $id]} {
#quiet undefine - redefinition on registry change is expected, not noteworthy
@ -8548,7 +8569,12 @@ namespace eval punk {
punk::args::define {
@id -id ::punk::helptopic::topics
@cmd -name "help topics" -summary "List help topics." -help "Show the table of topics known to the help system, including registered aliases for each topic."
@cmd -name "help topics"\
-summary\
"List help topics."\
-help\
"Show the table of topics known to the help system,
including registered aliases for each topic."
@values -min 0 -max 0
}
proc topics {context args} {
@ -8570,7 +8596,15 @@ namespace eval punk {
punk::args::define {
@id -id ::punk::helptopic::tcl
@cmd -name "help tcl" -summary "Tcl version warnings." -help "Show the running Tcl patchlevel and build-info, with warnings for known Tcl bugs affecting this interpreter and known bugs in bundled library packages (as detected by the punk::lib::check::has_tclbug_* and has_libbug_* checks)."
@cmd -name "help tcl"\
-summary\
"Tcl version warnings."\
-help\
"Show the running Tcl patchlevel and build-info, with
warnings for known Tcl bugs affecting this interpreter
and known bugs in bundled library packages
(as detected by the punk::lib::check::has_tclbug_*
and has_libbug_* checks)."
@values -min 0 -max 0
}
proc tcl {context args} {
@ -8629,7 +8663,12 @@ namespace eval punk {
punk::args::define {
@id -id ::punk::helptopic::env
@cmd -name "help env" -summary "punkshell environment vars." -help "Show punk-related and other relevant environment variables with their current values."
@cmd -name "help env"\
-summary\
"punkshell environment vars."\
-help\
"Show punk-related and other relevant environment
variables with their current values."
@values -min 0 -max 0
}
proc env {context args} {
@ -8730,7 +8769,14 @@ namespace eval punk {
punk::args::define {
@id -id ::punk::helptopic::console
@cmd -name "help console" -summary "Console behaviour tests and warnings." -help "Run some console/terminal behaviour tests (control string hiding, grapheme cluster support, cursor position query timing) and report warnings. Requires a responsive interactive console."
@cmd -name "help console"\
-summary\
"Console behaviour tests and warnings."\
-help\
"Run some console/terminal behaviour tests (control
string hiding, grapheme cluster support, cursor
position query timing) and report warnings.
Requires a responsive interactive console."
@values -min 0 -max 0
}
proc console {context args} {
@ -9357,7 +9403,7 @@ punkcheck::cli set_alias punkcheck
package provide punk [namespace eval punk {
#FUNCTL
variable version
set version 0.2.1
set version 0.2.3
}]

382
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.3.tm → src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.3.2.tm
Unescape View File

@ -8,7 +8,7 @@
# (C) 2024
#
# @@ Meta Begin
# Application punk::args 0.2.3
# Application punk::args 0.3.2
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
@ -18,7 +18,7 @@
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin punkshell_module_punk::args 0 0.2.3]
#[manpage_begin punkshell_module_punk::args 0 0.3.2]
#[copyright "2024"]
#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}]
#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}]
@ -416,7 +416,7 @@ tcl::namespace::eval ::punk::args::helpers {
}
if {$opt_title ne ""} {
set title "[punk::ansi::a+ term-black Term-silver]$opt_title[a]"
set title "[punk::ansi::a+ term-black Term-silver]$opt_title[punk::ansi::a]"
} else {
set title ""
}
@ -911,6 +911,25 @@ tcl::namespace::eval punk::args {
env, envi, ... environment all normalize to environment.
(To require a longer minimum, reserve each shorter form:
reserving {en env} raises the minimum to envi.)
-choicealiases {<dict>}
Dictionary mapping alias names to canonical choice names.
An alias is accepted wherever its canonical choice is: an
exact alias match works regardless of -choiceprefix, and
when -choiceprefix is true alias names participate in
prefix calculation so a unique prefix of an alias also
matches. A matched alias is normalized: the parse result
contains the canonical choice, never the alias.
Aliases are not displayed as separate choice entries -
usage display folds them into the canonical entry as an
'(alias: name)' note on its label. -choicelabels keys
should be canonical names only.
An alias listed in -choiceprefixdenylist must be typed
in full (denial applies to the alias name; a canonical
reached via its alias is not subject to the canonical's
own denylist entry).
Each alias must map to an existing choice, and must not
itself collide with a choice (validated when the
definition is resolved).
-choicegroups {<dict>}
Generally this would be used instead of -choices to allow
usage display of choices grouped by some name (or the empty
@ -2642,6 +2661,17 @@ tcl::namespace::eval punk::args {
}
tcl::dict::set spec_merged -mash $specval
}
-choicealiases {
#dict of alias -> canonical choice (goal G-040).
#Aliases are accepted at parse (exact, and as prefix-calculation members when
#-choiceprefix applies) and normalize to their canonical choice in the parse
#result; usage display folds them into the canonical entry.
#Cross-validation against the final choice set happens after all specs merge.
if {![punk::args::lib::string_is_dict $specval]} {
error "punk::args::resolve - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary of alias -> canonical-choice @id:$DEF_definition_id"
}
tcl::dict::set spec_merged $spec $specval
}
-unindentedfields -
-solo -
-choices - -choicegroups - -choicemultiple - -choicecolumns -
@ -2761,7 +2791,7 @@ tcl::namespace::eval punk::args {
-minsize -maxsize -choices -choicegroups
-mincap -maxcap
-choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted
-choicelabels -choiceinfo
-choicelabels -choiceinfo -choicealiases
-unindentedfields
-nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help
-multipleunique -choicemultipleunique -choicemultipleuniqueset
@ -2774,6 +2804,21 @@ tcl::namespace::eval punk::args {
}
} ;# end foreach {spec specval} argdef_values
#cross-validate -choicealiases against the final merged choice set (goal G-040)
if {[tcl::dict::exists $spec_merged -choicealiases] && [tcl::dict::size [tcl::dict::get $spec_merged -choicealiases]]} {
set ca_allchoices [punk::args::system::Dict_getdef $spec_merged -choices {}]
foreach {_cagroup camembers} [punk::args::system::Dict_getdef $spec_merged -choicegroups {}] {
lappend ca_allchoices {*}$camembers
}
tcl::dict::for {ca_alias ca_canonical} [tcl::dict::get $spec_merged -choicealiases] {
if {$ca_canonical ni $ca_allchoices} {
error "punk::args::resolve - -choicealiases for argument '$argname' maps alias '$ca_alias' to '$ca_canonical' which is not in -choices/-choicegroups @id:$DEF_definition_id"
}
if {$ca_alias in $ca_allchoices} {
error "punk::args::resolve - -choicealiases for argument '$argname' alias '$ca_alias' collides with a defined choice @id:$DEF_definition_id"
}
}
}
if {$is_opt} {
#tcl::dict::set FDICT ARG_CHECKS $argname {*}{
@ -4811,12 +4856,15 @@ tcl::namespace::eval punk::args {
if {$has_choices} {
if {$help ne ""} {append help \n}
#G-040: alias names participate in prefix calculation (as at parse time)
set choicealiases_display [Dict_getdef $arginfo -choicealiases {}]
set choicealias_names [dict keys $choicealiases_display]
if {[dict get $arginfo -nocase]} {
set casemsg " (case insensitive)"
set allchoices_prefixcalc [list {*}[string tolower $allchoices_originalcase] {*}$choiceprefixreservelist]
set allchoices_prefixcalc [list {*}[string tolower $allchoices_originalcase] {*}[string tolower $choicealias_names] {*}$choiceprefixreservelist]
} else {
set casemsg " (case sensitive)"
set allchoices_prefixcalc [list {*}$allchoices_originalcase {*}$choiceprefixreservelist]
set allchoices_prefixcalc [list {*}$allchoices_originalcase {*}$choicealias_names {*}$choiceprefixreservelist]
}
if {[dict get $arginfo -choiceprefix]} {
set prefixmsg " (choice prefix allowed)"
@ -4825,6 +4873,22 @@ tcl::namespace::eval punk::args {
}
set choicelabeldict [Dict_getdef $arginfo -choicelabels {}]
set choiceinfodict [Dict_getdef $arginfo -choiceinfo {}]
#G-040: aliases are not displayed as separate choice entries - fold each
#canonical's alias names into its label so every display path shows them once
if {[dict size $choicealiases_display]} {
set aliasesbycanonical [dict create]
dict for {ca_al ca_cn} $choicealiases_display {
dict lappend aliasesbycanonical $ca_cn $ca_al
}
dict for {ca_cn ca_als} $aliasesbycanonical {
set aliasnote "(alias[expr {[llength $ca_als] > 1 ? {es} : {}}]: [join $ca_als |])"
if {[dict exists $choicelabeldict $ca_cn]} {
dict set choicelabeldict $ca_cn "$aliasnote\n[dict get $choicelabeldict $ca_cn]"
} else {
dict set choicelabeldict $ca_cn $aliasnote
}
}
}
set formattedchoices [dict create] ;#use dict rather than array to preserve order
if {$help eq ""} {
#first line of help - no included base of 4 indent is the normal state of first help lines in definitions scripts
@ -8074,6 +8138,155 @@ tcl::namespace::eval punk::args {
#rename get_dict
#
#G-040: the single implementation of choice-word matching - shared by argument parsing
#(get_dict) and the punk::ns doc-lookup walk (cmd_traverse), so 'i <cmd> <word>'
#resolution can never diverge from what parsing accepts.
#Arguments:
# word - the supplied word (callers pass the check-form, e.g. ansistripped when applicable)
# nocase - value of -nocase for the argument
# allchoices - flat list of -choices plus all -choicegroups members (dups allowed)
# choicealiases - -choicealiases dict (alias -> canonical choice)
# choiceprefix - value of -choiceprefix
# denylist - -choiceprefixdenylist (full word required for these names)
# reservelist - -choiceprefixreservelist (phantom prefix-calculation members)
#Returns dict:
# matched - boolean: word identifies a choice (directly, by unique prefix, or via an alias)
# exact - boolean: the raw stored word already equals the resulting choice (no rewrite needed)
# canonical - the resulting choice value (empty when not matched)
proc choiceword_match {word nocase allchoices choicealiases choiceprefix denylist reservelist} {
set aliasnames [tcl::dict::keys $choicealiases]
set has_choicealiases [expr {[llength $aliasnames] > 0}]
set choicealiases_nocase [tcl::dict::create]
if {$has_choicealiases} {
tcl::dict::for {ca_al ca_cn} $choicealiases {
tcl::dict::set choicealiases_nocase [tcl::string::tolower $ca_al] $ca_cn
}
}
if {$nocase} {
set choices_test [tcl::string::tolower $allchoices]
set v_test [tcl::string::tolower $word]
} else {
set choices_test $allchoices
set v_test $word
}
set chosen ""
set choice_in_list 0
set choice_exact_match 0
if {$choiceprefix} {
#can we handle empty string as a choice? It should just work - REVIEW/test
if {$word in $allchoices} {
#for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing
set chosen $word
set choice_in_list 1
set choice_exact_match 1
} elseif {$has_choicealiases && [tcl::dict::exists $choicealiases $word]} {
#exact alias match - normalize to the canonical choice
#(deliberately not 'exact' - the stored raw value must be overwritten with the canonical)
set chosen [tcl::dict::get $choicealiases $word]
set choice_in_list 1
} elseif {$nocase && $v_test in $choices_test} {
#full-length match except for case
#select the case from the choice list - not the supplied value
foreach avail [lsort -unique $allchoices] {
if {[tcl::string::match -nocase $word $avail]} {
set chosen $avail
}
}
#assert chosen will always get set
set choice_in_list 1
} elseif {$has_choicealiases && $nocase && [tcl::dict::exists $choicealiases_nocase $v_test]} {
#exact alias match differing only by case - normalize to the canonical choice
set chosen [tcl::dict::get $choicealiases_nocase $v_test]
set choice_in_list 1
} else {
#PREFIX check required - any match here is not an exact match or it would have matched above.
#in this block we can treat empty result from prefix match as a non-match
set prefix_via_alias 0 ;#set when the prefix match landed on an alias name (deny already applied to the alias)
if {$nocase} {
#nocase prefixing with case-dups: see the -choiceprefixdenylist nocase notes at the original
#get_dict site - counterintuitive DEL/delete/Delete edge cases are documented feature-not-bug
set bestmatch [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$aliasnames {*}$reservelist] $word]
if {$bestmatch eq "" || $bestmatch in $reservelist} {
set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $choices_test] {*}[tcl::dict::keys $choicealiases_nocase] {*}$reservelist] $v_test]
if {$chosen ne "" && [tcl::dict::exists $choicealiases_nocase $chosen]} {
#matched an alias (lowercased) - deny applies to the alias name, then normalize
if {[lsearch -nocase $denylist $chosen] >= 0} {
set chosen ""
} else {
set chosen [tcl::dict::get $choicealiases_nocase $chosen]
set prefix_via_alias 1
}
set choice_in_list [expr {$chosen ne ""}]
} else {
#now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing
set chosen [lsearch -inline -nocase $allchoices $chosen]
set choice_in_list [expr {$chosen ne ""}]
}
} else {
if {$bestmatch in $aliasnames} {
#prefix landed on an alias - deny applies to the alias name, then normalize
if {$bestmatch in $denylist} {
set chosen ""
set choice_in_list 0
} else {
set chosen [tcl::dict::get $choicealiases $bestmatch]
set choice_in_list 1
set prefix_via_alias 1
}
} else {
set chosen $bestmatch
set choice_in_list 1
}
}
} else {
set matchedname [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$aliasnames {*}$reservelist] $word]
if {$matchedname eq "" || $matchedname in $reservelist} {
set chosen ""
set choice_in_list 0
} elseif {$matchedname in $aliasnames} {
#prefix landed on an alias - deny applies to the alias name, then normalize
if {$matchedname in $denylist} {
set chosen ""
set choice_in_list 0
} else {
set chosen [tcl::dict::get $choicealiases $matchedname]
set choice_in_list 1
set prefix_via_alias 1
}
} else {
set chosen $matchedname
set choice_in_list 1
}
}
#don't allow prefixing for elements from -choiceprefixdenylist
#we still use all elements to calculate the prefixes though
#(a canonical reached via an alias is exempt - deny was already applied to the alias name)
#review - case difference edge cases in choiceprefixdenylist !todo
if {!$prefix_via_alias && $chosen in $denylist} {
set choice_in_list 0
set chosen ""
}
}
} else {
#-choiceprefix false - exact matching only
if {$v_test in $choices_test} {
#value as stored is ok (raw word kept - historical behaviour, including nocase raw retention)
set chosen $word
set choice_in_list 1
set choice_exact_match 1
} elseif {$has_choicealiases && [tcl::dict::exists $choicealiases $word]} {
#exact alias match - normalize to the canonical choice
set chosen [tcl::dict::get $choicealiases $word]
set choice_in_list 1
} elseif {$has_choicealiases && $nocase && [tcl::dict::exists $choicealiases_nocase $v_test]} {
#exact alias match differing only by case - normalize to the canonical choice
set chosen [tcl::dict::get $choicealiases_nocase $v_test]
set choice_in_list 1
}
}
return [tcl::dict::create matched $choice_in_list exact $choice_exact_match canonical $chosen]
}
#generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values
#If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags.
#only supports -flag val pairs, not solo options
@ -10023,6 +10236,10 @@ tcl::namespace::eval punk::args {
set choiceprefix [tcl::dict::get $thisarg -choiceprefix]
set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}]
set choiceprefixreservelist [Dict_getdef $thisarg -choiceprefixreservelist {}]
#-choicealiases (G-040): alias -> canonical choice. Accepted exact (any -choiceprefix
#setting) and as prefix-calculation members when -choiceprefix is true; matched aliases
#normalize to their canonical choice in the parse result (see choiceword_match).
set choicealiases [Dict_getdef $thisarg -choicealiases {}]
set choicerestricted [tcl::dict::get $thisarg -choicerestricted]
set choicemultiple [tcl::dict::get $thisarg -choicemultiple]
if {[string is integer -strict $choicemultiple]} {
@ -10097,122 +10314,60 @@ tcl::namespace::eval punk::args {
set choice_in_list 0
set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval could be a list when -choicemultiple?
if {!$matches_default} {
if {$choiceprefix} {
#can we handle empty string as a choice? It should just work - REVIEW/test
set choice_exact_match 0
if {$c_check in $allchoices} {
#for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing
set chosen $c_check
set choice_in_list 1
set choice_exact_match 1
} elseif {$v_test in $choices_test} {
#assert - if we're here, nocase must be true
#we know choice is present as full-length match except for case
#now we want to select the case from the choice list - not the supplied value
#we don't set choice_exact_match - because we will need to override the optimistic existing val below
#review
foreach avail [lsort -unique $allchoices] {
if {[string match -nocase $c $avail]} {
set chosen $avail
}
}
#assert chosen will always get set
set choice_in_list 1
} else {
#puts ">>>> choiceprefixreservelist: $choiceprefixreservelist"
#PREFIX check required - any 'chosen' here is not an exact match or it would have matched above.
#assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above.
#in this block we can treat empty result from prefix match as a non-match
if {$nocase} {
#nocase implies that our entered value doesn't have to match case of choices -
#but we would still like to select the best match if there are case-dups.
#e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete
# selecting Del will find Delete, del will match delete (and raise error)
# but DEL will also match delete rather than Delete - so again an error is raised.
#This is counterintuitive with -nocase
#This is probably such an edge case that best served with documentation as a feature-not-bug
#Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete?
#The choice of the user to use -choiceprefixdenylist along with case-dups is the issue.
set bestmatch [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check]
if {$bestmatch eq "" || $bestmatch in $choiceprefixreservelist} {
set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $choices_test] {*}$choiceprefixreservelist] $v_test]
#now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing
set chosen [lsearch -inline -nocase $allchoices $chosen]
set choice_in_list [expr {$chosen ne ""}]
#G-040: choice-word matching delegated to the shared resolver
#(punk::args::choiceword_match - also consumed by the punk::ns doc-lookup
# walk, so 'i <cmd> <word>' resolution cannot diverge from parsing)
set matchinfo [choiceword_match $c_check $nocase $allchoices $choicealiases $choiceprefix $choiceprefixdenylist $choiceprefixreservelist]
set choice_in_list [tcl::dict::get $matchinfo matched]
set choice_exact_match [tcl::dict::get $matchinfo exact]
set chosen [tcl::dict::get $matchinfo canonical]
#override the optimistic existing val (prefix-normalized or alias-normalized matches)
#our existing values in $dname are not list-protected - so we need to check clause_size
if {$choice_in_list && !$choice_exact_match} {
set existing [tcl::dict::get [set $dname] $argname_or_ident]
if {$choicemultiple_max != -1 && $choicemultiple_max < 2} {
#single choice allowed per clause-member
if {$is_multiple} {
if {$clause_size == 1} {
#no list wrapping of single element in $dname dict - so don't index into it with element_index
#lset existing $element_index $chosen ;#wrong - test::punk::args test: choice_multiple_with_choiceprefix.
lset existing $clause_index $chosen
} else {
set chosen $bestmatch
set choice_in_list 1
lset existing $clause_index $element_index $chosen
}
tcl::dict::set $dname $argname_or_ident $existing
} else {
set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check]
if {$chosen eq "" || $chosen in $choiceprefixreservelist} {
set choice_in_list 0
} else {
set choice_in_list 1
}
}
#override choice_in_list if in deny list
#don't allow prefixing for elements from -choiceprefixdenylist
#we still use all elements to calculate the prefixes though
#review - case difference edge cases in choiceprefixdenylist !todo
if {$chosen in $choiceprefixdenylist} {
set choice_in_list 0
set chosen ""
#test: choice_multielement_clause
lset existing $element_index $chosen
tcl::dict::set $dname $argname_or_ident $existing
}
}
#override the optimistic existing val
#our existing values in $dname are not list-protected - so we need to check clause_size
if {$choice_in_list && !$choice_exact_match} {
set existing [tcl::dict::get [set $dname] $argname_or_ident]
if {$choicemultiple_max != -1 && $choicemultiple_max < 2} {
#single choice allowed per clause-member
if {$is_multiple} {
if {$clause_size == 1} {
#no list wrapping of single element in $dname dict - so don't index into it with element_index
#lset existing $element_index $chosen ;#wrong - test::punk::args test: choice_multiple_with_choiceprefix.
lset existing $clause_index $chosen
} else {
lset existing $clause_index $element_index $chosen
}
tcl::dict::set $dname $argname_or_ident $existing
} else {
if {$is_multiple} {
#puts ">>> existing $existing $choice_idx"
if {$clause_size == 1} {
#no list wrapping of single element in $dname dict - so don't index into it with element_index
lset existing $clause_index $choice_idx $chosen
} else {
#test: choice_multielement_clause
lset existing $element_index $chosen
tcl::dict::set $dname $argname_or_ident $existing
lset existing $clause_index $element_index $choice_idx $chosen
}
tcl::dict::set $dname $argname_or_ident $existing
} else {
if {$is_multiple} {
#puts ">>> existing $existing $choice_idx"
if {$clause_size == 1} {
#no list wrapping of single element in $dname dict - so don't index into it with element_index
lset existing $clause_index $choice_idx $chosen
} else {
lset existing $clause_index $element_index $choice_idx $chosen
}
tcl::dict::set $dname $argname_or_ident $existing
#test required.
# punk::args::parse {{read write w}} withdef @values {mode -type list -choices {read write} -choicemultiple {1 -1}}
#puts ">>> clause_size $clause_size"
#puts ">>> existing $existing"
#puts ">>> lset existing $element_index $choice_idx $chosen"
if {$clause_size == 1} {
#e.g -type list
#we have multiple choices allowed for a single element clause because that clause type is a list.
lset existing $choice_idx $chosen
} else {
#test required.
# punk::args::parse {{read write w}} withdef @values {mode -type list -choices {read write} -choicemultiple {1 -1}}
#puts ">>> clause_size $clause_size"
#puts ">>> existing $existing"
#puts ">>> lset existing $element_index $choice_idx $chosen"
if {$clause_size == 1} {
#e.g -type list
#we have multiple choices allowed for a single element clause because that clause type is a list.
lset existing $choice_idx $chosen
} else {
#e.g -type {any any}
lset existing $element_index $choice_idx $chosen
}
tcl::dict::set $dname $argname_or_ident $existing
#e.g -type {any any}
lset existing $element_index $choice_idx $chosen
}
tcl::dict::set $dname $argname_or_ident $existing
}
}
} else {
#value as stored in $dname is ok
set choice_in_list [expr {$v_test in $choices_test}]
}
}
@ -11435,7 +11590,8 @@ tcl::namespace::eval punk::args::lib {
#The internal rep can be an 'arithseries' with no string representation
proc zero_based_posns {count} {
if {$count < 1} {return}
lseq 0 $count-1
#expr wrapper required: lseq in Tcl 9.1+ (TIP 746) no longer evaluates expression operands
lseq 0 [expr {$count-1}]
}
} else {
proc zero_based_posns {count} {
@ -12395,7 +12551,7 @@ package provide punk::args [tcl::namespace::eval punk::args {
tcl::namespace::path {::punk::args::lib ::punk::args::system}
variable pkg punk::args
variable version
set version 0.2.3
set version 0.3.2
}]
return

38
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.3.0.tm → src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.3.1.tm
Unescape View File

@ -8,7 +8,7 @@
# (C) 2024
#
# @@ Meta Begin
# Application punk::lib 0.3.0
# Application punk::lib 0.3.1
# Meta platform tcl
# Meta license BSD
# @@ Meta End
@ -18,7 +18,7 @@
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin punkshell_module_punk::lib 0 0.3.0]
#[manpage_begin punkshell_module_punk::lib 0 0.3.1]
#[copyright "2024"]
#[titledesc {punk general utility functions}] [comment {-- Name section and table of contents description --}]
#[moddesc {punk library}] [comment {-- Description at end of page heading --}]
@ -320,7 +320,10 @@ tcl::namespace::eval punk::lib::check {
interp create x -safe
} errMsg]} {
x eval {proc ensembletest {} {string index a 0}}
set bytecode_safe [x eval {tcl::unsupported::disassemble proc ::ensembletest}]
if {[catch {x eval {tcl::unsupported::disassemble proc ::ensembletest}} bytecode_safe]} {
#Tcl 9.1+ removes tcl::unsupported::* from safe interps - disassemble is instead a hidden command (tcl:unsupported:disassemble)
set bytecode_safe [interp invokehidden x tcl:unsupported:disassemble proc ::ensembletest]
}
if {$show} {
puts safe:
puts $bytecode_safe
@ -1311,14 +1314,27 @@ namespace eval punk::lib {
#tcl 8.7+ lseq significantly faster, especially for larger ranges
#The internal rep can be an 'arithseries' with no string representation
#support minimal set from to
proc range {from to {by 1}} {
proc range {from to {by ""}} {
#note inconsistency with lseq 1 10 by -9 vs lseq 1 10 by -10
#https://core.tcl-lang.org/tcl/tktview/999b6966b2
#lseq in Tcl 9.1+ no longer evaluates expression operands such as 4-1 (TIP 746)
#range continues to accept int[+-]int offset forms e.g `range 0 [llength $list]-1` (same contract as the non-lseq fallback below)
if {![string is double -strict $from]} {set from [offset_expr $from]}
if {![string is double -strict $to]} {set to [offset_expr $to]}
if {$by eq ""} {
#direction inferred - lseq produces a descending sequence when from > to (matching the non-lseq fallback below)
return [lseq $from $to]
}
if {![string is double -strict $by]} {set by [offset_expr $by]}
if {$by == 0} {
#documented range behaviour (and lseq behaviour prior to Tcl 9.1): a step of zero produces no results
return [list]
}
lseq $from $to by $by
}
} else {
#lseq accepts basic expressions e.g 4-2 for both arguments
#e.g we can do lseq 0 [llength $list]-1
#lseq prior to Tcl 9.1 (TIP 746) accepted basic expressions e.g 4-2 for both arguments
#range accepts int[+-]int offset forms in all branches e.g we can do range 0 [llength $list]-1
#if range is to be consistent with the lseq version above - it should support that, even though we don't support most lseq functionality in either wrapper.
#our range function doesn't support double like lseq does. (deliberate) review
proc range {from to {by ""}} {
@ -1595,7 +1611,7 @@ namespace eval punk::lib {
foreach len $lens list $args {
lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""]
}
lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *}
lmap c [lseq 0 [expr {$numcolumns-1}]] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *}
}
proc lzipn_tcl9c {args} {
#SLOW
@ -1614,7 +1630,7 @@ namespace eval punk::lib {
}
lappend zip_l [lsearch -stride $cols_remaining -index 0 -inline -all -subindices $flatlist *]
set flen [llength $flatlist]
set flatlist [lremove $flatlist {*}[lseq 0 to $flen-1 by $cols_remaining]]
set flatlist [lremove $flatlist {*}[lseq 0 to [expr {$flen-1}] by $cols_remaining]]
incr cols_remaining -1
}
return $zip_l
@ -8613,14 +8629,14 @@ tcl::namespace::eval punk::lib::flatgrid {
}
proc cols {list numcolumns {blank NULL}} {
set cols [list]
foreach colindex [lseq 0 $numcolumns-1] {
foreach colindex [lseq 0 [expr {$numcolumns-1}]] {
lappend cols [lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] *]
}
return $cols
}
proc cols2 {list numcolumns {blank NULL}} {
set cols [list]
foreach colindex [lseq 0 $numcolumns-1] {
foreach colindex [lseq 0 [expr {$numcolumns-1}]] {
lappend cols [col2 $list $numcolumns $colindex $blank]
}
return $cols
@ -9119,7 +9135,7 @@ namespace eval ::punk::args::register {
package provide punk::lib [tcl::namespace::eval punk::lib {
variable pkg punk::lib
variable version
set version 0.3.0
set version 0.3.1
}]
return

28
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.1.tm → src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.2.tm
Unescape View File

@ -7,7 +7,7 @@
# (C) 2023
#
# @@ Meta Begin
# Application punk::ns 0.1.1
# Application punk::ns 0.1.2
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
@ -5154,16 +5154,26 @@ y" {return quirkykeyscript}
return [list 3 $origin $resolvedargs [list {*}$eparams {*}$queryargs_untested] $docid]
break
}
set resolved_q [tcl::prefix::match -error "" $allchoices $q]
if {$resolved_q eq ""} {
#G-040: resolve the subcommand word with the same shared resolver argument
#parsing uses (punk::args::choiceword_match) - so aliases normalize to their
#canonical (choiceinfo is keyed on canonicals), -choiceprefixdenylist and
#-choiceprefixreservelist are honoured, and 'i <cmd> <word>' can never accept
#a word that parsing would reject.
set ct_matchinfo [punk::args::choiceword_match $q\
[punk::args::system::Dict_getdef $arginfo -nocase 0]\
$allchoices\
[punk::args::system::Dict_getdef $arginfo -choicealiases {}]\
[dict get $arginfo -choiceprefix]\
[punk::args::system::Dict_getdef $arginfo -choiceprefixdenylist {}]\
[punk::args::system::Dict_getdef $arginfo -choiceprefixreservelist {}]\
]
if {![dict get $ct_matchinfo matched]} {
#no match under parse rules (covers: unknown word, ambiguous prefix,
#reserved word, denied prefix, and non-exact word when -choiceprefix 0)
return [list 4 $origin $resolvedargs $queryargs_untested $docid]
break
}
if {![dict get $arginfo -choiceprefix] && $resolved_q ne $q} {
#a unique prefix is not sufficient for this arg
return [list 5 $origin $resolvedargs $queryargs_untested $docid]
break
}
set resolved_q [dict get $ct_matchinfo canonical]
#if {$resolved_q ne $q} {
@ -7591,6 +7601,6 @@ namespace eval ::punk::args::register {
## Ready
package provide punk::ns [tcl::namespace::eval punk::ns {
variable version
set version 0.1.1
set version 0.1.2
}]
return

78
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.2.1.tm → src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.2.3.tm
Unescape View File

@ -8464,35 +8464,56 @@ namespace eval punk {
#(re)generate the punk::args definitions for ::punk::help and ::punk::help_chunks from the registry
#so that 'i help' shows a documented topic table matching the registered topics.
#minimum-prefix policy for topic words (user decision 2026-07-08):
# - prefixes of the 'help' alias are denied: h/he/hel stay available as command
# words ('help' itself must be typed in full)
# - c, to and tc are reserved phantoms so they fall through to command lookup
# (co.../top.../full 'tcl' still match; e/en and te/ter fall through naturally
# as ambiguous prefixes of env|environment and term|terminal)
variable topic_prefixdenylist {help}
variable topic_prefixreservelist {c to tc}
proc define_docs {} {
variable topics
variable topic_prefixdenylist
variable topic_prefixreservelist
#G-040: canonical topic names are the choices; registry aliases become
#-choicealiases (accepted + normalized at parse, folded into the canonical
#entry in usage display). choiceinfo/choicelabels key on canonicals only.
set choices [list]
set choicealiases [dict create]
set choiceinfo [dict create]
set choicelabels [dict create]
dict for {topic tinfo} $topics {
foreach name [list $topic {*}[dict get $tinfo aliases]] {
lappend choices $name
dict set choiceinfo $name [list [list doctype punkargs] [list subhelp [namespace current]::$topic]]
dict set choicelabels $name [dict get $tinfo summary]
lappend choices $topic
dict set choiceinfo $topic [list [list doctype punkargs] [list subhelp [namespace current]::$topic]]
dict set choicelabels $topic [dict get $tinfo summary]
foreach al [dict get $tinfo aliases] {
dict set choicealiases $al $topic
}
}
#keep help-text lines manually folded (~70 cols) - the usage tables don't yet
#wrap to terminal width, so line lengths here directly set the table width
set basehelp {Help system for the punk shell.
With no arguments - an overview of some key shell commands is displayed.
When the first argument is a recognised topic - help for that topic is displayed.
With no arguments - an overview of some key shell
commands is displayed.
When the first argument is a recognised topic - help
for that topic is displayed.
('help topics' lists the available topics)
Anything else is treated as a command name - basic command info (type and
synopsis) is shown for a resolvable command, or the resolved path for an
Anything else is treated as a command name - basic
command info (type and synopsis) is shown for a
resolvable command, or the resolved path for an
external executable.}
set topichelp {Help topic, or command words for basic command info. (topics must match exactly - no prefix matching)}
set topichelp "Help topic, or command words for basic command info.\nTopics accept their aliases and unique prefixes\n(some short words deliberately fall through to command lookup)."
set specs [list]
lappend specs ::punk::help help "Punk shell help system." ""
lappend specs ::punk::help_chunks punk::help_chunks "Punk shell help system - content as {channel text} chunks." "\n\nhelp_chunks returns the help content as a list of {channel text} chunks rather than emitting it."
lappend specs ::punk::help_chunks punk::help_chunks "Punk shell help system - content as {channel text} chunks." "\n\nhelp_chunks returns the help content as a list of\n{channel text} chunks rather than emitting it."
foreach {id name summary extra} $specs {
set def ""
append def "@id -id $id" \n
append def "@cmd -name $name -summary \"$summary\" -help \"$basehelp$extra\"" \n
append def "@leaders -min 0 -max -1" \n
append def "topic -optional 1 -multiple 1 -type string -choiceprefix 0 -choicerestricted 0 -choices {$choices} -choiceinfo {$choiceinfo} -choicelabels {$choicelabels} -help \"$topichelp\"" \n
append def "topic -optional 1 -multiple 1 -type string -choiceprefix 1 -choicerestricted 0 -choicecolumns 2 -choices {$choices} -choicealiases {$choicealiases} -choiceprefixdenylist {$topic_prefixdenylist} -choiceprefixreservelist {$topic_prefixreservelist} -choiceinfo {$choiceinfo} -choicelabels {$choicelabels} -help \"$topichelp\"" \n
append def "@values -min 0 -max 0"
if {[punk::args::id_exists $id]} {
#quiet undefine - redefinition on registry change is expected, not noteworthy
@ -8548,7 +8569,12 @@ namespace eval punk {
punk::args::define {
@id -id ::punk::helptopic::topics
@cmd -name "help topics" -summary "List help topics." -help "Show the table of topics known to the help system, including registered aliases for each topic."
@cmd -name "help topics"\
-summary\
"List help topics."\
-help\
"Show the table of topics known to the help system,
including registered aliases for each topic."
@values -min 0 -max 0
}
proc topics {context args} {
@ -8570,7 +8596,15 @@ namespace eval punk {
punk::args::define {
@id -id ::punk::helptopic::tcl
@cmd -name "help tcl" -summary "Tcl version warnings." -help "Show the running Tcl patchlevel and build-info, with warnings for known Tcl bugs affecting this interpreter and known bugs in bundled library packages (as detected by the punk::lib::check::has_tclbug_* and has_libbug_* checks)."
@cmd -name "help tcl"\
-summary\
"Tcl version warnings."\
-help\
"Show the running Tcl patchlevel and build-info, with
warnings for known Tcl bugs affecting this interpreter
and known bugs in bundled library packages
(as detected by the punk::lib::check::has_tclbug_*
and has_libbug_* checks)."
@values -min 0 -max 0
}
proc tcl {context args} {
@ -8629,7 +8663,12 @@ namespace eval punk {
punk::args::define {
@id -id ::punk::helptopic::env
@cmd -name "help env" -summary "punkshell environment vars." -help "Show punk-related and other relevant environment variables with their current values."
@cmd -name "help env"\
-summary\
"punkshell environment vars."\
-help\
"Show punk-related and other relevant environment
variables with their current values."
@values -min 0 -max 0
}
proc env {context args} {
@ -8730,7 +8769,14 @@ namespace eval punk {
punk::args::define {
@id -id ::punk::helptopic::console
@cmd -name "help console" -summary "Console behaviour tests and warnings." -help "Run some console/terminal behaviour tests (control string hiding, grapheme cluster support, cursor position query timing) and report warnings. Requires a responsive interactive console."
@cmd -name "help console"\
-summary\
"Console behaviour tests and warnings."\
-help\
"Run some console/terminal behaviour tests (control
string hiding, grapheme cluster support, cursor
position query timing) and report warnings.
Requires a responsive interactive console."
@values -min 0 -max 0
}
proc console {context args} {
@ -9357,7 +9403,7 @@ punkcheck::cli set_alias punkcheck
package provide punk [namespace eval punk {
#FUNCTL
variable version
set version 0.2.1
set version 0.2.3
}]

382
src/bootsupport/modules/punk/args-0.2.3.tm → src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.3.2.tm
Unescape View File

@ -8,7 +8,7 @@
# (C) 2024
#
# @@ Meta Begin
# Application punk::args 0.2.3
# Application punk::args 0.3.2
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
@ -18,7 +18,7 @@
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin punkshell_module_punk::args 0 0.2.3]
#[manpage_begin punkshell_module_punk::args 0 0.3.2]
#[copyright "2024"]
#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}]
#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}]
@ -416,7 +416,7 @@ tcl::namespace::eval ::punk::args::helpers {
}
if {$opt_title ne ""} {
set title "[punk::ansi::a+ term-black Term-silver]$opt_title[a]"
set title "[punk::ansi::a+ term-black Term-silver]$opt_title[punk::ansi::a]"
} else {
set title ""
}
@ -911,6 +911,25 @@ tcl::namespace::eval punk::args {
env, envi, ... environment all normalize to environment.
(To require a longer minimum, reserve each shorter form:
reserving {en env} raises the minimum to envi.)
-choicealiases {<dict>}
Dictionary mapping alias names to canonical choice names.
An alias is accepted wherever its canonical choice is: an
exact alias match works regardless of -choiceprefix, and
when -choiceprefix is true alias names participate in
prefix calculation so a unique prefix of an alias also
matches. A matched alias is normalized: the parse result
contains the canonical choice, never the alias.
Aliases are not displayed as separate choice entries -
usage display folds them into the canonical entry as an
'(alias: name)' note on its label. -choicelabels keys
should be canonical names only.
An alias listed in -choiceprefixdenylist must be typed
in full (denial applies to the alias name; a canonical
reached via its alias is not subject to the canonical's
own denylist entry).
Each alias must map to an existing choice, and must not
itself collide with a choice (validated when the
definition is resolved).
-choicegroups {<dict>}
Generally this would be used instead of -choices to allow
usage display of choices grouped by some name (or the empty
@ -2642,6 +2661,17 @@ tcl::namespace::eval punk::args {
}
tcl::dict::set spec_merged -mash $specval
}
-choicealiases {
#dict of alias -> canonical choice (goal G-040).
#Aliases are accepted at parse (exact, and as prefix-calculation members when
#-choiceprefix applies) and normalize to their canonical choice in the parse
#result; usage display folds them into the canonical entry.
#Cross-validation against the final choice set happens after all specs merge.
if {![punk::args::lib::string_is_dict $specval]} {
error "punk::args::resolve - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary of alias -> canonical-choice @id:$DEF_definition_id"
}
tcl::dict::set spec_merged $spec $specval
}
-unindentedfields -
-solo -
-choices - -choicegroups - -choicemultiple - -choicecolumns -
@ -2761,7 +2791,7 @@ tcl::namespace::eval punk::args {
-minsize -maxsize -choices -choicegroups
-mincap -maxcap
-choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted
-choicelabels -choiceinfo
-choicelabels -choiceinfo -choicealiases
-unindentedfields
-nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help
-multipleunique -choicemultipleunique -choicemultipleuniqueset
@ -2774,6 +2804,21 @@ tcl::namespace::eval punk::args {
}
} ;# end foreach {spec specval} argdef_values
#cross-validate -choicealiases against the final merged choice set (goal G-040)
if {[tcl::dict::exists $spec_merged -choicealiases] && [tcl::dict::size [tcl::dict::get $spec_merged -choicealiases]]} {
set ca_allchoices [punk::args::system::Dict_getdef $spec_merged -choices {}]
foreach {_cagroup camembers} [punk::args::system::Dict_getdef $spec_merged -choicegroups {}] {
lappend ca_allchoices {*}$camembers
}
tcl::dict::for {ca_alias ca_canonical} [tcl::dict::get $spec_merged -choicealiases] {
if {$ca_canonical ni $ca_allchoices} {
error "punk::args::resolve - -choicealiases for argument '$argname' maps alias '$ca_alias' to '$ca_canonical' which is not in -choices/-choicegroups @id:$DEF_definition_id"
}
if {$ca_alias in $ca_allchoices} {
error "punk::args::resolve - -choicealiases for argument '$argname' alias '$ca_alias' collides with a defined choice @id:$DEF_definition_id"
}
}
}
if {$is_opt} {
#tcl::dict::set FDICT ARG_CHECKS $argname {*}{
@ -4811,12 +4856,15 @@ tcl::namespace::eval punk::args {
if {$has_choices} {
if {$help ne ""} {append help \n}
#G-040: alias names participate in prefix calculation (as at parse time)
set choicealiases_display [Dict_getdef $arginfo -choicealiases {}]
set choicealias_names [dict keys $choicealiases_display]
if {[dict get $arginfo -nocase]} {
set casemsg " (case insensitive)"
set allchoices_prefixcalc [list {*}[string tolower $allchoices_originalcase] {*}$choiceprefixreservelist]
set allchoices_prefixcalc [list {*}[string tolower $allchoices_originalcase] {*}[string tolower $choicealias_names] {*}$choiceprefixreservelist]
} else {
set casemsg " (case sensitive)"
set allchoices_prefixcalc [list {*}$allchoices_originalcase {*}$choiceprefixreservelist]
set allchoices_prefixcalc [list {*}$allchoices_originalcase {*}$choicealias_names {*}$choiceprefixreservelist]
}
if {[dict get $arginfo -choiceprefix]} {
set prefixmsg " (choice prefix allowed)"
@ -4825,6 +4873,22 @@ tcl::namespace::eval punk::args {
}
set choicelabeldict [Dict_getdef $arginfo -choicelabels {}]
set choiceinfodict [Dict_getdef $arginfo -choiceinfo {}]
#G-040: aliases are not displayed as separate choice entries - fold each
#canonical's alias names into its label so every display path shows them once
if {[dict size $choicealiases_display]} {
set aliasesbycanonical [dict create]
dict for {ca_al ca_cn} $choicealiases_display {
dict lappend aliasesbycanonical $ca_cn $ca_al
}
dict for {ca_cn ca_als} $aliasesbycanonical {
set aliasnote "(alias[expr {[llength $ca_als] > 1 ? {es} : {}}]: [join $ca_als |])"
if {[dict exists $choicelabeldict $ca_cn]} {
dict set choicelabeldict $ca_cn "$aliasnote\n[dict get $choicelabeldict $ca_cn]"
} else {
dict set choicelabeldict $ca_cn $aliasnote
}
}
}
set formattedchoices [dict create] ;#use dict rather than array to preserve order
if {$help eq ""} {
#first line of help - no included base of 4 indent is the normal state of first help lines in definitions scripts
@ -8074,6 +8138,155 @@ tcl::namespace::eval punk::args {
#rename get_dict
#
#G-040: the single implementation of choice-word matching - shared by argument parsing
#(get_dict) and the punk::ns doc-lookup walk (cmd_traverse), so 'i <cmd> <word>'
#resolution can never diverge from what parsing accepts.
#Arguments:
# word - the supplied word (callers pass the check-form, e.g. ansistripped when applicable)
# nocase - value of -nocase for the argument
# allchoices - flat list of -choices plus all -choicegroups members (dups allowed)
# choicealiases - -choicealiases dict (alias -> canonical choice)
# choiceprefix - value of -choiceprefix
# denylist - -choiceprefixdenylist (full word required for these names)
# reservelist - -choiceprefixreservelist (phantom prefix-calculation members)
#Returns dict:
# matched - boolean: word identifies a choice (directly, by unique prefix, or via an alias)
# exact - boolean: the raw stored word already equals the resulting choice (no rewrite needed)
# canonical - the resulting choice value (empty when not matched)
proc choiceword_match {word nocase allchoices choicealiases choiceprefix denylist reservelist} {
set aliasnames [tcl::dict::keys $choicealiases]
set has_choicealiases [expr {[llength $aliasnames] > 0}]
set choicealiases_nocase [tcl::dict::create]
if {$has_choicealiases} {
tcl::dict::for {ca_al ca_cn} $choicealiases {
tcl::dict::set choicealiases_nocase [tcl::string::tolower $ca_al] $ca_cn
}
}
if {$nocase} {
set choices_test [tcl::string::tolower $allchoices]
set v_test [tcl::string::tolower $word]
} else {
set choices_test $allchoices
set v_test $word
}
set chosen ""
set choice_in_list 0
set choice_exact_match 0
if {$choiceprefix} {
#can we handle empty string as a choice? It should just work - REVIEW/test
if {$word in $allchoices} {
#for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing
set chosen $word
set choice_in_list 1
set choice_exact_match 1
} elseif {$has_choicealiases && [tcl::dict::exists $choicealiases $word]} {
#exact alias match - normalize to the canonical choice
#(deliberately not 'exact' - the stored raw value must be overwritten with the canonical)
set chosen [tcl::dict::get $choicealiases $word]
set choice_in_list 1
} elseif {$nocase && $v_test in $choices_test} {
#full-length match except for case
#select the case from the choice list - not the supplied value
foreach avail [lsort -unique $allchoices] {
if {[tcl::string::match -nocase $word $avail]} {
set chosen $avail
}
}
#assert chosen will always get set
set choice_in_list 1
} elseif {$has_choicealiases && $nocase && [tcl::dict::exists $choicealiases_nocase $v_test]} {
#exact alias match differing only by case - normalize to the canonical choice
set chosen [tcl::dict::get $choicealiases_nocase $v_test]
set choice_in_list 1
} else {
#PREFIX check required - any match here is not an exact match or it would have matched above.
#in this block we can treat empty result from prefix match as a non-match
set prefix_via_alias 0 ;#set when the prefix match landed on an alias name (deny already applied to the alias)
if {$nocase} {
#nocase prefixing with case-dups: see the -choiceprefixdenylist nocase notes at the original
#get_dict site - counterintuitive DEL/delete/Delete edge cases are documented feature-not-bug
set bestmatch [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$aliasnames {*}$reservelist] $word]
if {$bestmatch eq "" || $bestmatch in $reservelist} {
set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $choices_test] {*}[tcl::dict::keys $choicealiases_nocase] {*}$reservelist] $v_test]
if {$chosen ne "" && [tcl::dict::exists $choicealiases_nocase $chosen]} {
#matched an alias (lowercased) - deny applies to the alias name, then normalize
if {[lsearch -nocase $denylist $chosen] >= 0} {
set chosen ""
} else {
set chosen [tcl::dict::get $choicealiases_nocase $chosen]
set prefix_via_alias 1
}
set choice_in_list [expr {$chosen ne ""}]
} else {
#now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing
set chosen [lsearch -inline -nocase $allchoices $chosen]
set choice_in_list [expr {$chosen ne ""}]
}
} else {
if {$bestmatch in $aliasnames} {
#prefix landed on an alias - deny applies to the alias name, then normalize
if {$bestmatch in $denylist} {
set chosen ""
set choice_in_list 0
} else {
set chosen [tcl::dict::get $choicealiases $bestmatch]
set choice_in_list 1
set prefix_via_alias 1
}
} else {
set chosen $bestmatch
set choice_in_list 1
}
}
} else {
set matchedname [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$aliasnames {*}$reservelist] $word]
if {$matchedname eq "" || $matchedname in $reservelist} {
set chosen ""
set choice_in_list 0
} elseif {$matchedname in $aliasnames} {
#prefix landed on an alias - deny applies to the alias name, then normalize
if {$matchedname in $denylist} {
set chosen ""
set choice_in_list 0
} else {
set chosen [tcl::dict::get $choicealiases $matchedname]
set choice_in_list 1
set prefix_via_alias 1
}
} else {
set chosen $matchedname
set choice_in_list 1
}
}
#don't allow prefixing for elements from -choiceprefixdenylist
#we still use all elements to calculate the prefixes though
#(a canonical reached via an alias is exempt - deny was already applied to the alias name)
#review - case difference edge cases in choiceprefixdenylist !todo
if {!$prefix_via_alias && $chosen in $denylist} {
set choice_in_list 0
set chosen ""
}
}
} else {
#-choiceprefix false - exact matching only
if {$v_test in $choices_test} {
#value as stored is ok (raw word kept - historical behaviour, including nocase raw retention)
set chosen $word
set choice_in_list 1
set choice_exact_match 1
} elseif {$has_choicealiases && [tcl::dict::exists $choicealiases $word]} {
#exact alias match - normalize to the canonical choice
set chosen [tcl::dict::get $choicealiases $word]
set choice_in_list 1
} elseif {$has_choicealiases && $nocase && [tcl::dict::exists $choicealiases_nocase $v_test]} {
#exact alias match differing only by case - normalize to the canonical choice
set chosen [tcl::dict::get $choicealiases_nocase $v_test]
set choice_in_list 1
}
}
return [tcl::dict::create matched $choice_in_list exact $choice_exact_match canonical $chosen]
}
#generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values
#If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags.
#only supports -flag val pairs, not solo options
@ -10023,6 +10236,10 @@ tcl::namespace::eval punk::args {
set choiceprefix [tcl::dict::get $thisarg -choiceprefix]
set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}]
set choiceprefixreservelist [Dict_getdef $thisarg -choiceprefixreservelist {}]
#-choicealiases (G-040): alias -> canonical choice. Accepted exact (any -choiceprefix
#setting) and as prefix-calculation members when -choiceprefix is true; matched aliases
#normalize to their canonical choice in the parse result (see choiceword_match).
set choicealiases [Dict_getdef $thisarg -choicealiases {}]
set choicerestricted [tcl::dict::get $thisarg -choicerestricted]
set choicemultiple [tcl::dict::get $thisarg -choicemultiple]
if {[string is integer -strict $choicemultiple]} {
@ -10097,122 +10314,60 @@ tcl::namespace::eval punk::args {
set choice_in_list 0
set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval could be a list when -choicemultiple?
if {!$matches_default} {
if {$choiceprefix} {
#can we handle empty string as a choice? It should just work - REVIEW/test
set choice_exact_match 0
if {$c_check in $allchoices} {
#for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing
set chosen $c_check
set choice_in_list 1
set choice_exact_match 1
} elseif {$v_test in $choices_test} {
#assert - if we're here, nocase must be true
#we know choice is present as full-length match except for case
#now we want to select the case from the choice list - not the supplied value
#we don't set choice_exact_match - because we will need to override the optimistic existing val below
#review
foreach avail [lsort -unique $allchoices] {
if {[string match -nocase $c $avail]} {
set chosen $avail
}
}
#assert chosen will always get set
set choice_in_list 1
} else {
#puts ">>>> choiceprefixreservelist: $choiceprefixreservelist"
#PREFIX check required - any 'chosen' here is not an exact match or it would have matched above.
#assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above.
#in this block we can treat empty result from prefix match as a non-match
if {$nocase} {
#nocase implies that our entered value doesn't have to match case of choices -
#but we would still like to select the best match if there are case-dups.
#e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete
# selecting Del will find Delete, del will match delete (and raise error)
# but DEL will also match delete rather than Delete - so again an error is raised.
#This is counterintuitive with -nocase
#This is probably such an edge case that best served with documentation as a feature-not-bug
#Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete?
#The choice of the user to use -choiceprefixdenylist along with case-dups is the issue.
set bestmatch [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check]
if {$bestmatch eq "" || $bestmatch in $choiceprefixreservelist} {
set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $choices_test] {*}$choiceprefixreservelist] $v_test]
#now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing
set chosen [lsearch -inline -nocase $allchoices $chosen]
set choice_in_list [expr {$chosen ne ""}]
#G-040: choice-word matching delegated to the shared resolver
#(punk::args::choiceword_match - also consumed by the punk::ns doc-lookup
# walk, so 'i <cmd> <word>' resolution cannot diverge from parsing)
set matchinfo [choiceword_match $c_check $nocase $allchoices $choicealiases $choiceprefix $choiceprefixdenylist $choiceprefixreservelist]
set choice_in_list [tcl::dict::get $matchinfo matched]
set choice_exact_match [tcl::dict::get $matchinfo exact]
set chosen [tcl::dict::get $matchinfo canonical]
#override the optimistic existing val (prefix-normalized or alias-normalized matches)
#our existing values in $dname are not list-protected - so we need to check clause_size
if {$choice_in_list && !$choice_exact_match} {
set existing [tcl::dict::get [set $dname] $argname_or_ident]
if {$choicemultiple_max != -1 && $choicemultiple_max < 2} {
#single choice allowed per clause-member
if {$is_multiple} {
if {$clause_size == 1} {
#no list wrapping of single element in $dname dict - so don't index into it with element_index
#lset existing $element_index $chosen ;#wrong - test::punk::args test: choice_multiple_with_choiceprefix.
lset existing $clause_index $chosen
} else {
set chosen $bestmatch
set choice_in_list 1
lset existing $clause_index $element_index $chosen
}
tcl::dict::set $dname $argname_or_ident $existing
} else {
set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check]
if {$chosen eq "" || $chosen in $choiceprefixreservelist} {
set choice_in_list 0
} else {
set choice_in_list 1
}
}
#override choice_in_list if in deny list
#don't allow prefixing for elements from -choiceprefixdenylist
#we still use all elements to calculate the prefixes though
#review - case difference edge cases in choiceprefixdenylist !todo
if {$chosen in $choiceprefixdenylist} {
set choice_in_list 0
set chosen ""
#test: choice_multielement_clause
lset existing $element_index $chosen
tcl::dict::set $dname $argname_or_ident $existing
}
}
#override the optimistic existing val
#our existing values in $dname are not list-protected - so we need to check clause_size
if {$choice_in_list && !$choice_exact_match} {
set existing [tcl::dict::get [set $dname] $argname_or_ident]
if {$choicemultiple_max != -1 && $choicemultiple_max < 2} {
#single choice allowed per clause-member
if {$is_multiple} {
if {$clause_size == 1} {
#no list wrapping of single element in $dname dict - so don't index into it with element_index
#lset existing $element_index $chosen ;#wrong - test::punk::args test: choice_multiple_with_choiceprefix.
lset existing $clause_index $chosen
} else {
lset existing $clause_index $element_index $chosen
}
tcl::dict::set $dname $argname_or_ident $existing
} else {
if {$is_multiple} {
#puts ">>> existing $existing $choice_idx"
if {$clause_size == 1} {
#no list wrapping of single element in $dname dict - so don't index into it with element_index
lset existing $clause_index $choice_idx $chosen
} else {
#test: choice_multielement_clause
lset existing $element_index $chosen
tcl::dict::set $dname $argname_or_ident $existing
lset existing $clause_index $element_index $choice_idx $chosen
}
tcl::dict::set $dname $argname_or_ident $existing
} else {
if {$is_multiple} {
#puts ">>> existing $existing $choice_idx"
if {$clause_size == 1} {
#no list wrapping of single element in $dname dict - so don't index into it with element_index
lset existing $clause_index $choice_idx $chosen
} else {
lset existing $clause_index $element_index $choice_idx $chosen
}
tcl::dict::set $dname $argname_or_ident $existing
#test required.
# punk::args::parse {{read write w}} withdef @values {mode -type list -choices {read write} -choicemultiple {1 -1}}
#puts ">>> clause_size $clause_size"
#puts ">>> existing $existing"
#puts ">>> lset existing $element_index $choice_idx $chosen"
if {$clause_size == 1} {
#e.g -type list
#we have multiple choices allowed for a single element clause because that clause type is a list.
lset existing $choice_idx $chosen
} else {
#test required.
# punk::args::parse {{read write w}} withdef @values {mode -type list -choices {read write} -choicemultiple {1 -1}}
#puts ">>> clause_size $clause_size"
#puts ">>> existing $existing"
#puts ">>> lset existing $element_index $choice_idx $chosen"
if {$clause_size == 1} {
#e.g -type list
#we have multiple choices allowed for a single element clause because that clause type is a list.
lset existing $choice_idx $chosen
} else {
#e.g -type {any any}
lset existing $element_index $choice_idx $chosen
}
tcl::dict::set $dname $argname_or_ident $existing
#e.g -type {any any}
lset existing $element_index $choice_idx $chosen
}
tcl::dict::set $dname $argname_or_ident $existing
}
}
} else {
#value as stored in $dname is ok
set choice_in_list [expr {$v_test in $choices_test}]
}
}
@ -11435,7 +11590,8 @@ tcl::namespace::eval punk::args::lib {
#The internal rep can be an 'arithseries' with no string representation
proc zero_based_posns {count} {
if {$count < 1} {return}
lseq 0 $count-1
#expr wrapper required: lseq in Tcl 9.1+ (TIP 746) no longer evaluates expression operands
lseq 0 [expr {$count-1}]
}
} else {
proc zero_based_posns {count} {
@ -12395,7 +12551,7 @@ package provide punk::args [tcl::namespace::eval punk::args {
tcl::namespace::path {::punk::args::lib ::punk::args::system}
variable pkg punk::args
variable version
set version 0.2.3
set version 0.3.2
}]
return

38
src/bootsupport/modules/punk/lib-0.3.0.tm → src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.3.1.tm
Unescape View File

@ -8,7 +8,7 @@
# (C) 2024
#
# @@ Meta Begin
# Application punk::lib 0.3.0
# Application punk::lib 0.3.1
# Meta platform tcl
# Meta license BSD
# @@ Meta End
@ -18,7 +18,7 @@
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin punkshell_module_punk::lib 0 0.3.0]
#[manpage_begin punkshell_module_punk::lib 0 0.3.1]
#[copyright "2024"]
#[titledesc {punk general utility functions}] [comment {-- Name section and table of contents description --}]
#[moddesc {punk library}] [comment {-- Description at end of page heading --}]
@ -320,7 +320,10 @@ tcl::namespace::eval punk::lib::check {
interp create x -safe
} errMsg]} {
x eval {proc ensembletest {} {string index a 0}}
set bytecode_safe [x eval {tcl::unsupported::disassemble proc ::ensembletest}]
if {[catch {x eval {tcl::unsupported::disassemble proc ::ensembletest}} bytecode_safe]} {
#Tcl 9.1+ removes tcl::unsupported::* from safe interps - disassemble is instead a hidden command (tcl:unsupported:disassemble)
set bytecode_safe [interp invokehidden x tcl:unsupported:disassemble proc ::ensembletest]
}
if {$show} {
puts safe:
puts $bytecode_safe
@ -1311,14 +1314,27 @@ namespace eval punk::lib {
#tcl 8.7+ lseq significantly faster, especially for larger ranges
#The internal rep can be an 'arithseries' with no string representation
#support minimal set from to
proc range {from to {by 1}} {
proc range {from to {by ""}} {
#note inconsistency with lseq 1 10 by -9 vs lseq 1 10 by -10
#https://core.tcl-lang.org/tcl/tktview/999b6966b2
#lseq in Tcl 9.1+ no longer evaluates expression operands such as 4-1 (TIP 746)
#range continues to accept int[+-]int offset forms e.g `range 0 [llength $list]-1` (same contract as the non-lseq fallback below)
if {![string is double -strict $from]} {set from [offset_expr $from]}
if {![string is double -strict $to]} {set to [offset_expr $to]}
if {$by eq ""} {
#direction inferred - lseq produces a descending sequence when from > to (matching the non-lseq fallback below)
return [lseq $from $to]
}
if {![string is double -strict $by]} {set by [offset_expr $by]}
if {$by == 0} {
#documented range behaviour (and lseq behaviour prior to Tcl 9.1): a step of zero produces no results
return [list]
}
lseq $from $to by $by
}
} else {
#lseq accepts basic expressions e.g 4-2 for both arguments
#e.g we can do lseq 0 [llength $list]-1
#lseq prior to Tcl 9.1 (TIP 746) accepted basic expressions e.g 4-2 for both arguments
#range accepts int[+-]int offset forms in all branches e.g we can do range 0 [llength $list]-1
#if range is to be consistent with the lseq version above - it should support that, even though we don't support most lseq functionality in either wrapper.
#our range function doesn't support double like lseq does. (deliberate) review
proc range {from to {by ""}} {
@ -1595,7 +1611,7 @@ namespace eval punk::lib {
foreach len $lens list $args {
lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""]
}
lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *}
lmap c [lseq 0 [expr {$numcolumns-1}]] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *}
}
proc lzipn_tcl9c {args} {
#SLOW
@ -1614,7 +1630,7 @@ namespace eval punk::lib {
}
lappend zip_l [lsearch -stride $cols_remaining -index 0 -inline -all -subindices $flatlist *]
set flen [llength $flatlist]
set flatlist [lremove $flatlist {*}[lseq 0 to $flen-1 by $cols_remaining]]
set flatlist [lremove $flatlist {*}[lseq 0 to [expr {$flen-1}] by $cols_remaining]]
incr cols_remaining -1
}
return $zip_l
@ -8613,14 +8629,14 @@ tcl::namespace::eval punk::lib::flatgrid {
}
proc cols {list numcolumns {blank NULL}} {
set cols [list]
foreach colindex [lseq 0 $numcolumns-1] {
foreach colindex [lseq 0 [expr {$numcolumns-1}]] {
lappend cols [lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] *]
}
return $cols
}
proc cols2 {list numcolumns {blank NULL}} {
set cols [list]
foreach colindex [lseq 0 $numcolumns-1] {
foreach colindex [lseq 0 [expr {$numcolumns-1}]] {
lappend cols [col2 $list $numcolumns $colindex $blank]
}
return $cols
@ -9119,7 +9135,7 @@ namespace eval ::punk::args::register {
package provide punk::lib [tcl::namespace::eval punk::lib {
variable pkg punk::lib
variable version
set version 0.3.0
set version 0.3.1
}]
return

28
src/bootsupport/modules/punk/ns-0.1.1.tm → src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.2.tm
Unescape View File

@ -7,7 +7,7 @@
# (C) 2023
#
# @@ Meta Begin
# Application punk::ns 0.1.1
# Application punk::ns 0.1.2
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
@ -5154,16 +5154,26 @@ y" {return quirkykeyscript}
return [list 3 $origin $resolvedargs [list {*}$eparams {*}$queryargs_untested] $docid]
break
}
set resolved_q [tcl::prefix::match -error "" $allchoices $q]
if {$resolved_q eq ""} {
#G-040: resolve the subcommand word with the same shared resolver argument
#parsing uses (punk::args::choiceword_match) - so aliases normalize to their
#canonical (choiceinfo is keyed on canonicals), -choiceprefixdenylist and
#-choiceprefixreservelist are honoured, and 'i <cmd> <word>' can never accept
#a word that parsing would reject.
set ct_matchinfo [punk::args::choiceword_match $q\
[punk::args::system::Dict_getdef $arginfo -nocase 0]\
$allchoices\
[punk::args::system::Dict_getdef $arginfo -choicealiases {}]\
[dict get $arginfo -choiceprefix]\
[punk::args::system::Dict_getdef $arginfo -choiceprefixdenylist {}]\
[punk::args::system::Dict_getdef $arginfo -choiceprefixreservelist {}]\
]
if {![dict get $ct_matchinfo matched]} {
#no match under parse rules (covers: unknown word, ambiguous prefix,
#reserved word, denied prefix, and non-exact word when -choiceprefix 0)
return [list 4 $origin $resolvedargs $queryargs_untested $docid]
break
}
if {![dict get $arginfo -choiceprefix] && $resolved_q ne $q} {
#a unique prefix is not sufficient for this arg
return [list 5 $origin $resolvedargs $queryargs_untested $docid]
break
}
set resolved_q [dict get $ct_matchinfo canonical]
#if {$resolved_q ne $q} {
@ -7591,6 +7601,6 @@ namespace eval ::punk::args::register {
## Ready
package provide punk::ns [tcl::namespace::eval punk::ns {
variable version
set version 0.1.1
set version 0.1.2
}]
return

382
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.3.tm → src/vfs/_vfscommon.vfs/modules/punk/args-0.3.2.tm
Unescape View File

@ -8,7 +8,7 @@
# (C) 2024
#
# @@ Meta Begin
# Application punk::args 0.2.3
# Application punk::args 0.3.2
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
@ -18,7 +18,7 @@
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin punkshell_module_punk::args 0 0.2.3]
#[manpage_begin punkshell_module_punk::args 0 0.3.2]
#[copyright "2024"]
#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}]
#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}]
@ -416,7 +416,7 @@ tcl::namespace::eval ::punk::args::helpers {
}
if {$opt_title ne ""} {
set title "[punk::ansi::a+ term-black Term-silver]$opt_title[a]"
set title "[punk::ansi::a+ term-black Term-silver]$opt_title[punk::ansi::a]"
} else {
set title ""
}
@ -911,6 +911,25 @@ tcl::namespace::eval punk::args {
env, envi, ... environment all normalize to environment.
(To require a longer minimum, reserve each shorter form:
reserving {en env} raises the minimum to envi.)
-choicealiases {<dict>}
Dictionary mapping alias names to canonical choice names.
An alias is accepted wherever its canonical choice is: an
exact alias match works regardless of -choiceprefix, and
when -choiceprefix is true alias names participate in
prefix calculation so a unique prefix of an alias also
matches. A matched alias is normalized: the parse result
contains the canonical choice, never the alias.
Aliases are not displayed as separate choice entries -
usage display folds them into the canonical entry as an
'(alias: name)' note on its label. -choicelabels keys
should be canonical names only.
An alias listed in -choiceprefixdenylist must be typed
in full (denial applies to the alias name; a canonical
reached via its alias is not subject to the canonical's
own denylist entry).
Each alias must map to an existing choice, and must not
itself collide with a choice (validated when the
definition is resolved).
-choicegroups {<dict>}
Generally this would be used instead of -choices to allow
usage display of choices grouped by some name (or the empty
@ -2642,6 +2661,17 @@ tcl::namespace::eval punk::args {
}
tcl::dict::set spec_merged -mash $specval
}
-choicealiases {
#dict of alias -> canonical choice (goal G-040).
#Aliases are accepted at parse (exact, and as prefix-calculation members when
#-choiceprefix applies) and normalize to their canonical choice in the parse
#result; usage display folds them into the canonical entry.
#Cross-validation against the final choice set happens after all specs merge.
if {![punk::args::lib::string_is_dict $specval]} {
error "punk::args::resolve - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary of alias -> canonical-choice @id:$DEF_definition_id"
}
tcl::dict::set spec_merged $spec $specval
}
-unindentedfields -
-solo -
-choices - -choicegroups - -choicemultiple - -choicecolumns -
@ -2761,7 +2791,7 @@ tcl::namespace::eval punk::args {
-minsize -maxsize -choices -choicegroups
-mincap -maxcap
-choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted
-choicelabels -choiceinfo
-choicelabels -choiceinfo -choicealiases
-unindentedfields
-nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help
-multipleunique -choicemultipleunique -choicemultipleuniqueset
@ -2774,6 +2804,21 @@ tcl::namespace::eval punk::args {
}
} ;# end foreach {spec specval} argdef_values
#cross-validate -choicealiases against the final merged choice set (goal G-040)
if {[tcl::dict::exists $spec_merged -choicealiases] && [tcl::dict::size [tcl::dict::get $spec_merged -choicealiases]]} {
set ca_allchoices [punk::args::system::Dict_getdef $spec_merged -choices {}]
foreach {_cagroup camembers} [punk::args::system::Dict_getdef $spec_merged -choicegroups {}] {
lappend ca_allchoices {*}$camembers
}
tcl::dict::for {ca_alias ca_canonical} [tcl::dict::get $spec_merged -choicealiases] {
if {$ca_canonical ni $ca_allchoices} {
error "punk::args::resolve - -choicealiases for argument '$argname' maps alias '$ca_alias' to '$ca_canonical' which is not in -choices/-choicegroups @id:$DEF_definition_id"
}
if {$ca_alias in $ca_allchoices} {
error "punk::args::resolve - -choicealiases for argument '$argname' alias '$ca_alias' collides with a defined choice @id:$DEF_definition_id"
}
}
}
if {$is_opt} {
#tcl::dict::set FDICT ARG_CHECKS $argname {*}{
@ -4811,12 +4856,15 @@ tcl::namespace::eval punk::args {
if {$has_choices} {
if {$help ne ""} {append help \n}
#G-040: alias names participate in prefix calculation (as at parse time)
set choicealiases_display [Dict_getdef $arginfo -choicealiases {}]
set choicealias_names [dict keys $choicealiases_display]
if {[dict get $arginfo -nocase]} {
set casemsg " (case insensitive)"
set allchoices_prefixcalc [list {*}[string tolower $allchoices_originalcase] {*}$choiceprefixreservelist]
set allchoices_prefixcalc [list {*}[string tolower $allchoices_originalcase] {*}[string tolower $choicealias_names] {*}$choiceprefixreservelist]
} else {
set casemsg " (case sensitive)"
set allchoices_prefixcalc [list {*}$allchoices_originalcase {*}$choiceprefixreservelist]
set allchoices_prefixcalc [list {*}$allchoices_originalcase {*}$choicealias_names {*}$choiceprefixreservelist]
}
if {[dict get $arginfo -choiceprefix]} {
set prefixmsg " (choice prefix allowed)"
@ -4825,6 +4873,22 @@ tcl::namespace::eval punk::args {
}
set choicelabeldict [Dict_getdef $arginfo -choicelabels {}]
set choiceinfodict [Dict_getdef $arginfo -choiceinfo {}]
#G-040: aliases are not displayed as separate choice entries - fold each
#canonical's alias names into its label so every display path shows them once
if {[dict size $choicealiases_display]} {
set aliasesbycanonical [dict create]
dict for {ca_al ca_cn} $choicealiases_display {
dict lappend aliasesbycanonical $ca_cn $ca_al
}
dict for {ca_cn ca_als} $aliasesbycanonical {
set aliasnote "(alias[expr {[llength $ca_als] > 1 ? {es} : {}}]: [join $ca_als |])"
if {[dict exists $choicelabeldict $ca_cn]} {
dict set choicelabeldict $ca_cn "$aliasnote\n[dict get $choicelabeldict $ca_cn]"
} else {
dict set choicelabeldict $ca_cn $aliasnote
}
}
}
set formattedchoices [dict create] ;#use dict rather than array to preserve order
if {$help eq ""} {
#first line of help - no included base of 4 indent is the normal state of first help lines in definitions scripts
@ -8074,6 +8138,155 @@ tcl::namespace::eval punk::args {
#rename get_dict
#
#G-040: the single implementation of choice-word matching - shared by argument parsing
#(get_dict) and the punk::ns doc-lookup walk (cmd_traverse), so 'i <cmd> <word>'
#resolution can never diverge from what parsing accepts.
#Arguments:
# word - the supplied word (callers pass the check-form, e.g. ansistripped when applicable)
# nocase - value of -nocase for the argument
# allchoices - flat list of -choices plus all -choicegroups members (dups allowed)
# choicealiases - -choicealiases dict (alias -> canonical choice)
# choiceprefix - value of -choiceprefix
# denylist - -choiceprefixdenylist (full word required for these names)
# reservelist - -choiceprefixreservelist (phantom prefix-calculation members)
#Returns dict:
# matched - boolean: word identifies a choice (directly, by unique prefix, or via an alias)
# exact - boolean: the raw stored word already equals the resulting choice (no rewrite needed)
# canonical - the resulting choice value (empty when not matched)
proc choiceword_match {word nocase allchoices choicealiases choiceprefix denylist reservelist} {
set aliasnames [tcl::dict::keys $choicealiases]
set has_choicealiases [expr {[llength $aliasnames] > 0}]
set choicealiases_nocase [tcl::dict::create]
if {$has_choicealiases} {
tcl::dict::for {ca_al ca_cn} $choicealiases {
tcl::dict::set choicealiases_nocase [tcl::string::tolower $ca_al] $ca_cn
}
}
if {$nocase} {
set choices_test [tcl::string::tolower $allchoices]
set v_test [tcl::string::tolower $word]
} else {
set choices_test $allchoices
set v_test $word
}
set chosen ""
set choice_in_list 0
set choice_exact_match 0
if {$choiceprefix} {
#can we handle empty string as a choice? It should just work - REVIEW/test
if {$word in $allchoices} {
#for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing
set chosen $word
set choice_in_list 1
set choice_exact_match 1
} elseif {$has_choicealiases && [tcl::dict::exists $choicealiases $word]} {
#exact alias match - normalize to the canonical choice
#(deliberately not 'exact' - the stored raw value must be overwritten with the canonical)
set chosen [tcl::dict::get $choicealiases $word]
set choice_in_list 1
} elseif {$nocase && $v_test in $choices_test} {
#full-length match except for case
#select the case from the choice list - not the supplied value
foreach avail [lsort -unique $allchoices] {
if {[tcl::string::match -nocase $word $avail]} {
set chosen $avail
}
}
#assert chosen will always get set
set choice_in_list 1
} elseif {$has_choicealiases && $nocase && [tcl::dict::exists $choicealiases_nocase $v_test]} {
#exact alias match differing only by case - normalize to the canonical choice
set chosen [tcl::dict::get $choicealiases_nocase $v_test]
set choice_in_list 1
} else {
#PREFIX check required - any match here is not an exact match or it would have matched above.
#in this block we can treat empty result from prefix match as a non-match
set prefix_via_alias 0 ;#set when the prefix match landed on an alias name (deny already applied to the alias)
if {$nocase} {
#nocase prefixing with case-dups: see the -choiceprefixdenylist nocase notes at the original
#get_dict site - counterintuitive DEL/delete/Delete edge cases are documented feature-not-bug
set bestmatch [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$aliasnames {*}$reservelist] $word]
if {$bestmatch eq "" || $bestmatch in $reservelist} {
set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $choices_test] {*}[tcl::dict::keys $choicealiases_nocase] {*}$reservelist] $v_test]
if {$chosen ne "" && [tcl::dict::exists $choicealiases_nocase $chosen]} {
#matched an alias (lowercased) - deny applies to the alias name, then normalize
if {[lsearch -nocase $denylist $chosen] >= 0} {
set chosen ""
} else {
set chosen [tcl::dict::get $choicealiases_nocase $chosen]
set prefix_via_alias 1
}
set choice_in_list [expr {$chosen ne ""}]
} else {
#now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing
set chosen [lsearch -inline -nocase $allchoices $chosen]
set choice_in_list [expr {$chosen ne ""}]
}
} else {
if {$bestmatch in $aliasnames} {
#prefix landed on an alias - deny applies to the alias name, then normalize
if {$bestmatch in $denylist} {
set chosen ""
set choice_in_list 0
} else {
set chosen [tcl::dict::get $choicealiases $bestmatch]
set choice_in_list 1
set prefix_via_alias 1
}
} else {
set chosen $bestmatch
set choice_in_list 1
}
}
} else {
set matchedname [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$aliasnames {*}$reservelist] $word]
if {$matchedname eq "" || $matchedname in $reservelist} {
set chosen ""
set choice_in_list 0
} elseif {$matchedname in $aliasnames} {
#prefix landed on an alias - deny applies to the alias name, then normalize
if {$matchedname in $denylist} {
set chosen ""
set choice_in_list 0
} else {
set chosen [tcl::dict::get $choicealiases $matchedname]
set choice_in_list 1
set prefix_via_alias 1
}
} else {
set chosen $matchedname
set choice_in_list 1
}
}
#don't allow prefixing for elements from -choiceprefixdenylist
#we still use all elements to calculate the prefixes though
#(a canonical reached via an alias is exempt - deny was already applied to the alias name)
#review - case difference edge cases in choiceprefixdenylist !todo
if {!$prefix_via_alias && $chosen in $denylist} {
set choice_in_list 0
set chosen ""
}
}
} else {
#-choiceprefix false - exact matching only
if {$v_test in $choices_test} {
#value as stored is ok (raw word kept - historical behaviour, including nocase raw retention)
set chosen $word
set choice_in_list 1
set choice_exact_match 1
} elseif {$has_choicealiases && [tcl::dict::exists $choicealiases $word]} {
#exact alias match - normalize to the canonical choice
set chosen [tcl::dict::get $choicealiases $word]
set choice_in_list 1
} elseif {$has_choicealiases && $nocase && [tcl::dict::exists $choicealiases_nocase $v_test]} {
#exact alias match differing only by case - normalize to the canonical choice
set chosen [tcl::dict::get $choicealiases_nocase $v_test]
set choice_in_list 1
}
}
return [tcl::dict::create matched $choice_in_list exact $choice_exact_match canonical $chosen]
}
#generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values
#If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags.
#only supports -flag val pairs, not solo options
@ -10023,6 +10236,10 @@ tcl::namespace::eval punk::args {
set choiceprefix [tcl::dict::get $thisarg -choiceprefix]
set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}]
set choiceprefixreservelist [Dict_getdef $thisarg -choiceprefixreservelist {}]
#-choicealiases (G-040): alias -> canonical choice. Accepted exact (any -choiceprefix
#setting) and as prefix-calculation members when -choiceprefix is true; matched aliases
#normalize to their canonical choice in the parse result (see choiceword_match).
set choicealiases [Dict_getdef $thisarg -choicealiases {}]
set choicerestricted [tcl::dict::get $thisarg -choicerestricted]
set choicemultiple [tcl::dict::get $thisarg -choicemultiple]
if {[string is integer -strict $choicemultiple]} {
@ -10097,122 +10314,60 @@ tcl::namespace::eval punk::args {
set choice_in_list 0
set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval could be a list when -choicemultiple?
if {!$matches_default} {
if {$choiceprefix} {
#can we handle empty string as a choice? It should just work - REVIEW/test
set choice_exact_match 0
if {$c_check in $allchoices} {
#for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing
set chosen $c_check
set choice_in_list 1
set choice_exact_match 1
} elseif {$v_test in $choices_test} {
#assert - if we're here, nocase must be true
#we know choice is present as full-length match except for case
#now we want to select the case from the choice list - not the supplied value
#we don't set choice_exact_match - because we will need to override the optimistic existing val below
#review
foreach avail [lsort -unique $allchoices] {
if {[string match -nocase $c $avail]} {
set chosen $avail
}
}
#assert chosen will always get set
set choice_in_list 1
} else {
#puts ">>>> choiceprefixreservelist: $choiceprefixreservelist"
#PREFIX check required - any 'chosen' here is not an exact match or it would have matched above.
#assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above.
#in this block we can treat empty result from prefix match as a non-match
if {$nocase} {
#nocase implies that our entered value doesn't have to match case of choices -
#but we would still like to select the best match if there are case-dups.
#e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete
# selecting Del will find Delete, del will match delete (and raise error)
# but DEL will also match delete rather than Delete - so again an error is raised.
#This is counterintuitive with -nocase
#This is probably such an edge case that best served with documentation as a feature-not-bug
#Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete?
#The choice of the user to use -choiceprefixdenylist along with case-dups is the issue.
set bestmatch [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check]
if {$bestmatch eq "" || $bestmatch in $choiceprefixreservelist} {
set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $choices_test] {*}$choiceprefixreservelist] $v_test]
#now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing
set chosen [lsearch -inline -nocase $allchoices $chosen]
set choice_in_list [expr {$chosen ne ""}]
#G-040: choice-word matching delegated to the shared resolver
#(punk::args::choiceword_match - also consumed by the punk::ns doc-lookup
# walk, so 'i <cmd> <word>' resolution cannot diverge from parsing)
set matchinfo [choiceword_match $c_check $nocase $allchoices $choicealiases $choiceprefix $choiceprefixdenylist $choiceprefixreservelist]
set choice_in_list [tcl::dict::get $matchinfo matched]
set choice_exact_match [tcl::dict::get $matchinfo exact]
set chosen [tcl::dict::get $matchinfo canonical]
#override the optimistic existing val (prefix-normalized or alias-normalized matches)
#our existing values in $dname are not list-protected - so we need to check clause_size
if {$choice_in_list && !$choice_exact_match} {
set existing [tcl::dict::get [set $dname] $argname_or_ident]
if {$choicemultiple_max != -1 && $choicemultiple_max < 2} {
#single choice allowed per clause-member
if {$is_multiple} {
if {$clause_size == 1} {
#no list wrapping of single element in $dname dict - so don't index into it with element_index
#lset existing $element_index $chosen ;#wrong - test::punk::args test: choice_multiple_with_choiceprefix.
lset existing $clause_index $chosen
} else {
set chosen $bestmatch
set choice_in_list 1
lset existing $clause_index $element_index $chosen
}
tcl::dict::set $dname $argname_or_ident $existing
} else {
set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check]
if {$chosen eq "" || $chosen in $choiceprefixreservelist} {
set choice_in_list 0
} else {
set choice_in_list 1
}
}
#override choice_in_list if in deny list
#don't allow prefixing for elements from -choiceprefixdenylist
#we still use all elements to calculate the prefixes though
#review - case difference edge cases in choiceprefixdenylist !todo
if {$chosen in $choiceprefixdenylist} {
set choice_in_list 0
set chosen ""
#test: choice_multielement_clause
lset existing $element_index $chosen
tcl::dict::set $dname $argname_or_ident $existing
}
}
#override the optimistic existing val
#our existing values in $dname are not list-protected - so we need to check clause_size
if {$choice_in_list && !$choice_exact_match} {
set existing [tcl::dict::get [set $dname] $argname_or_ident]
if {$choicemultiple_max != -1 && $choicemultiple_max < 2} {
#single choice allowed per clause-member
if {$is_multiple} {
if {$clause_size == 1} {
#no list wrapping of single element in $dname dict - so don't index into it with element_index
#lset existing $element_index $chosen ;#wrong - test::punk::args test: choice_multiple_with_choiceprefix.
lset existing $clause_index $chosen
} else {
lset existing $clause_index $element_index $chosen
}
tcl::dict::set $dname $argname_or_ident $existing
} else {
if {$is_multiple} {
#puts ">>> existing $existing $choice_idx"
if {$clause_size == 1} {
#no list wrapping of single element in $dname dict - so don't index into it with element_index
lset existing $clause_index $choice_idx $chosen
} else {
#test: choice_multielement_clause
lset existing $element_index $chosen
tcl::dict::set $dname $argname_or_ident $existing
lset existing $clause_index $element_index $choice_idx $chosen
}
tcl::dict::set $dname $argname_or_ident $existing
} else {
if {$is_multiple} {
#puts ">>> existing $existing $choice_idx"
if {$clause_size == 1} {
#no list wrapping of single element in $dname dict - so don't index into it with element_index
lset existing $clause_index $choice_idx $chosen
} else {
lset existing $clause_index $element_index $choice_idx $chosen
}
tcl::dict::set $dname $argname_or_ident $existing
#test required.
# punk::args::parse {{read write w}} withdef @values {mode -type list -choices {read write} -choicemultiple {1 -1}}
#puts ">>> clause_size $clause_size"
#puts ">>> existing $existing"
#puts ">>> lset existing $element_index $choice_idx $chosen"
if {$clause_size == 1} {
#e.g -type list
#we have multiple choices allowed for a single element clause because that clause type is a list.
lset existing $choice_idx $chosen
} else {
#test required.
# punk::args::parse {{read write w}} withdef @values {mode -type list -choices {read write} -choicemultiple {1 -1}}
#puts ">>> clause_size $clause_size"
#puts ">>> existing $existing"
#puts ">>> lset existing $element_index $choice_idx $chosen"
if {$clause_size == 1} {
#e.g -type list
#we have multiple choices allowed for a single element clause because that clause type is a list.
lset existing $choice_idx $chosen
} else {
#e.g -type {any any}
lset existing $element_index $choice_idx $chosen
}
tcl::dict::set $dname $argname_or_ident $existing
#e.g -type {any any}
lset existing $element_index $choice_idx $chosen
}
tcl::dict::set $dname $argname_or_ident $existing
}
}
} else {
#value as stored in $dname is ok
set choice_in_list [expr {$v_test in $choices_test}]
}
}
@ -11435,7 +11590,8 @@ tcl::namespace::eval punk::args::lib {
#The internal rep can be an 'arithseries' with no string representation
proc zero_based_posns {count} {
if {$count < 1} {return}
lseq 0 $count-1
#expr wrapper required: lseq in Tcl 9.1+ (TIP 746) no longer evaluates expression operands
lseq 0 [expr {$count-1}]
}
} else {
proc zero_based_posns {count} {
@ -12395,7 +12551,7 @@ package provide punk::args [tcl::namespace::eval punk::args {
tcl::namespace::path {::punk::args::lib ::punk::args::system}
variable pkg punk::args
variable version
set version 0.2.3
set version 0.3.2
}]
return

38
src/vfs/_vfscommon.vfs/modules/punk/lib-0.3.0.tm → src/vfs/_vfscommon.vfs/modules/punk/lib-0.3.1.tm
Unescape View File

@ -8,7 +8,7 @@
# (C) 2024
#
# @@ Meta Begin
# Application punk::lib 0.3.0
# Application punk::lib 0.3.1
# Meta platform tcl
# Meta license BSD
# @@ Meta End
@ -18,7 +18,7 @@
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin punkshell_module_punk::lib 0 0.3.0]
#[manpage_begin punkshell_module_punk::lib 0 0.3.1]
#[copyright "2024"]
#[titledesc {punk general utility functions}] [comment {-- Name section and table of contents description --}]
#[moddesc {punk library}] [comment {-- Description at end of page heading --}]
@ -320,7 +320,10 @@ tcl::namespace::eval punk::lib::check {
interp create x -safe
} errMsg]} {
x eval {proc ensembletest {} {string index a 0}}
set bytecode_safe [x eval {tcl::unsupported::disassemble proc ::ensembletest}]
if {[catch {x eval {tcl::unsupported::disassemble proc ::ensembletest}} bytecode_safe]} {
#Tcl 9.1+ removes tcl::unsupported::* from safe interps - disassemble is instead a hidden command (tcl:unsupported:disassemble)
set bytecode_safe [interp invokehidden x tcl:unsupported:disassemble proc ::ensembletest]
}
if {$show} {
puts safe:
puts $bytecode_safe
@ -1311,14 +1314,27 @@ namespace eval punk::lib {
#tcl 8.7+ lseq significantly faster, especially for larger ranges
#The internal rep can be an 'arithseries' with no string representation
#support minimal set from to
proc range {from to {by 1}} {
proc range {from to {by ""}} {
#note inconsistency with lseq 1 10 by -9 vs lseq 1 10 by -10
#https://core.tcl-lang.org/tcl/tktview/999b6966b2
#lseq in Tcl 9.1+ no longer evaluates expression operands such as 4-1 (TIP 746)
#range continues to accept int[+-]int offset forms e.g `range 0 [llength $list]-1` (same contract as the non-lseq fallback below)
if {![string is double -strict $from]} {set from [offset_expr $from]}
if {![string is double -strict $to]} {set to [offset_expr $to]}
if {$by eq ""} {
#direction inferred - lseq produces a descending sequence when from > to (matching the non-lseq fallback below)
return [lseq $from $to]
}
if {![string is double -strict $by]} {set by [offset_expr $by]}
if {$by == 0} {
#documented range behaviour (and lseq behaviour prior to Tcl 9.1): a step of zero produces no results
return [list]
}
lseq $from $to by $by
}
} else {
#lseq accepts basic expressions e.g 4-2 for both arguments
#e.g we can do lseq 0 [llength $list]-1
#lseq prior to Tcl 9.1 (TIP 746) accepted basic expressions e.g 4-2 for both arguments
#range accepts int[+-]int offset forms in all branches e.g we can do range 0 [llength $list]-1
#if range is to be consistent with the lseq version above - it should support that, even though we don't support most lseq functionality in either wrapper.
#our range function doesn't support double like lseq does. (deliberate) review
proc range {from to {by ""}} {
@ -1595,7 +1611,7 @@ namespace eval punk::lib {
foreach len $lens list $args {
lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""]
}
lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *}
lmap c [lseq 0 [expr {$numcolumns-1}]] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *}
}
proc lzipn_tcl9c {args} {
#SLOW
@ -1614,7 +1630,7 @@ namespace eval punk::lib {
}
lappend zip_l [lsearch -stride $cols_remaining -index 0 -inline -all -subindices $flatlist *]
set flen [llength $flatlist]
set flatlist [lremove $flatlist {*}[lseq 0 to $flen-1 by $cols_remaining]]
set flatlist [lremove $flatlist {*}[lseq 0 to [expr {$flen-1}] by $cols_remaining]]
incr cols_remaining -1
}
return $zip_l
@ -8613,14 +8629,14 @@ tcl::namespace::eval punk::lib::flatgrid {
}
proc cols {list numcolumns {blank NULL}} {
set cols [list]
foreach colindex [lseq 0 $numcolumns-1] {
foreach colindex [lseq 0 [expr {$numcolumns-1}]] {
lappend cols [lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] *]
}
return $cols
}
proc cols2 {list numcolumns {blank NULL}} {
set cols [list]
foreach colindex [lseq 0 $numcolumns-1] {
foreach colindex [lseq 0 [expr {$numcolumns-1}]] {
lappend cols [col2 $list $numcolumns $colindex $blank]
}
return $cols
@ -9119,7 +9135,7 @@ namespace eval ::punk::args::register {
package provide punk::lib [tcl::namespace::eval punk::lib {
variable pkg punk::lib
variable version
set version 0.3.0
set version 0.3.1
}]
return
Write Preview
Loading…
Cancel
Save