#Should move to home position and reset ansi SGR when no save data available
#TODO
#?restore without save?
#should move to home position and reset ansi SGR?
#puts stderr "overtype::renderspace cursor_restore without save data available"
}
#If we were inserting prior to hitting the cursor_restore - there could be overflow_right data - generally the overtype functions aren't for inserting - but ansi can enable it
"Display PATH executable shadowing and conflicts with TCL commands"\
-help\
{Introspection of the PATH environment variable.
This tool will examine executables within each PATH entry and show which binaries
are overshadowed by earlier PATH entries. It can also be used to examine the contents of each PATH entry, and to filter results using glob patterns."
are overshadowed by earlier PATH entries.
It can also be used to examine the contents of each PATH entry, and to filter results using glob patterns.
${[punk::args::helpers::example {
#show all executables in all PATH entries
punk::path
#show all executables in all PATH entries that contain 'Windows' in the path
punk::path -pathglob *Windows*
#show all executables in all PATH entries that contain 'scoop' in the path,
#and filter the executables to show only those that are named dir, ls or start with 'ca'
punk::path -pathglob *scoop* dir ls ca*
#show all executables that conflict with TCL commands starting with 'a' in the current namespace.
punk::path {*}[nscommandlist a*]
#show all executables that conflict with TCL commands resolvable from the current namespace.
punk::path {*}[info commands]
}]}
see also the punk::auto_exec package.
}
@opts
-binglobs -type list -default {*} -help "glob pattern to filter results. Default '*' to include all entries."
-pathglob -type string -default {*} -multiple true -help "Case insensitive glob pattern to filter path entries. Default '*' to include all PATH directories."
@values -min 0 -max -1
glob -type string -default {*} -multiple true -optional 1 -help "Case insensitive glob pattern to filter path entries. Default '*' to include all PATH directories."
binglob -type list -default {*} -multiple true -optional 1 -help "glob pattern to filter results. Default '*' to include all entries."
}
}
variable d_path_info
variable d_bin_info
variable d_index_executables
#there is still a potential conflict regarding auto_execok on windows - which has some cmd.exe builtins as auto-executable
#- but these are not actually executable files on the filesystem - so they won't be found by our path search
#- but they will be found when not masked by a tcl command.
proc path {args} {
variable d_path_info
variable d_bin_info
variable d_index_executables
set is_windows [expr {$::tcl_platform(platform) eq "windows"}]
set argd [punk::args::parse $args withid ::punk::path]
lassign [dict values $argd] leaders opts values received
set binglobs [dict get $opts -binglobs]
set globs [dict get $values glob]
set pathglobs [dict get $opts -pathglob]
set binglobs [dict get $values binglob]
if {$::tcl_platform(platform) eq "windows"} {
set sep ";"
} else {
@ -6299,14 +6333,18 @@ namespace eval punk {
set sep ":"
}
set all_paths [split [string trimright $::env(PATH) $sep] $sep]
set filtered_paths $all_paths
if {[llength $globs]} {
set filtered_paths [list]
foreach p $all_paths {
foreach g $globs {
if {[string match -nocase $g $p]} {
lappend filtered_paths $p
break
if {[llength $pathglobs]} {
if {[lsearch -exact $pathglobs "*"] >= 0} {
#if we have a wildcard glob then the others are irrelevant - we want to match all paths
set matched_paths $all_paths
} else {
set matched_paths [list]
foreach p $all_paths {
foreach pg $pathglobs {
if {[string match -nocase $pg $p]} {
lappend matched_paths $p
break
}
}
}
}
@ -6344,6 +6382,60 @@ namespace eval punk {
#and the actual executable names (with case and extensions as they appear on the filesystem). We will also build a
#dict keyed by path index which contains the list of executables in that path - to make it easy to show which
#executables are overshadowed by which paths.
if {$is_windows} {
#Sometimes PATHEXT includes an entry of just a dot - which means files with no extension are considered executable.
#We need to account for this in our glob pattern.
set pathexts [list]
if {[info exists ::env(PATHEXT)]} {
set env_pathexts [split $::env(PATHEXT) ";"]
#set pathexts [lmap e $env_pathexts {string tolower $e}]
foreach pe $env_pathexts {
if {$pe eq "."} {
continue
}
lappend pathexts [string tolower $pe]
}
} else {
set env_pathexts [list]
#default PATHEXT if not set - according to Microsoft docs
set pathexts [list .com .exe .bat .cmd]
}
foreach bg $binglobs {
set has_pathext 0
foreach pe $pathexts {
if {[string match -nocase "*$pe" $bg]} {
set has_pathext 1
break
}
}
if {!$has_pathext} {
foreach pe $pathexts {
set globext "$bg$pe"
if {$globext ni $binglobs} {
lappend binglobs "$bg$pe"
}
}
}
}
set lc_binglobs [lmap e $binglobs {string tolower $e}]
if {"." in $pathexts} {
foreach bg $binglobs {
set has_pathext 0
foreach pe $pathexts {
if {[string match -nocase "*$pe" $bg]} {
set base [string range $bg 0 [expr {[string length $bg] - [string length $pe] - 1}]]
set has_pathext 1
break
}
}
if {$has_pathext} {
if {[string tolower $base] ni $lc_binglobs} {
lappend binglobs "$base"
}
}
}
}
}
set d_path_info [dict create] ;#key is normalized path (e.g case-insensitive on windows).
set d_bin_info [dict create] ;#key is normalized executable name (e.g case-insensitive on windows, or callable with extensions stripped off).
@ -6355,63 +6447,21 @@ namespace eval punk {
} else {
set pnorm $p
}
if {[string length $pnorm] > 1} {
set lastchar [string index $pnorm end]
if {$lastchar eq "/" || $lastchar eq "\\"} {
set pnorm [string range $pnorm 0 end-1]
}
}
if {![dict exists $d_path_info $pnorm]} {
dict set d_path_info $pnorm [dict create original_paths [list $p] indices [list $path_idx]]
set executables [list]
if {[file isdirectory $p]} {
#get all files that are executable in this path.
#If we don't normalize the path here - then trailing backslashes on windows can cause a problem with the -tail glob returning a leading slash on the executable names.
#also as we don't necessarily normalize the resulting final path with executable - we want the case to be correct.
set pnormglob [file normalize $p]
if {$::tcl_platform(platform) eq "windows"} {
#Sometimes PATHEXT includes an entry of just a dot - which means files with no extension are considered executable.
#We need to account for this in our glob pattern.
set pathexts [list]
if {[info exists ::env(PATHEXT)]} {
set env_pathexts [split $::env(PATHEXT) ";"]
#set pathexts [lmap e $env_pathexts {string tolower $e}]
foreach pe $env_pathexts {
if {$pe eq "."} {
continue
}
lappend pathexts [string tolower $pe]
}
} else {
set env_pathexts [list]
#default PATHEXT if not set - according to Microsoft docs
set pathexts [list .com .exe .bat .cmd]
}
foreach bg $binglobs {
set has_pathext 0
foreach pe $pathexts {
if {[string match -nocase "*$pe" $bg]} {
set has_pathext 1
break
}
}
if {!$has_pathext} {
foreach pe $pathexts {
lappend binglobs "$bg$pe"
}
}
}
set lc_binglobs [lmap e $binglobs {string tolower $e}]
if {"." in $pathexts} {
foreach bg $binglobs {
set has_pathext 0
foreach pe $pathexts {
if {[string match -nocase "*$pe" $bg]} {
set base [string range $bg 0 [expr {[string length $bg] - [string length $pe] - 1}]]
set has_pathext 1
break
}
}
if {$has_pathext} {
if {[string tolower $base] ni $lc_binglobs} {
lappend binglobs "$base"
}
}
}
}
#TCL's glob on windows is case-insensitive, but in some cases return the result with the case as globbed for regardless of the actual case on the filesystem.
#(This seems to occur when the pattern does *not* contain a wildcard and is probably a bug)
@ -6421,34 +6471,51 @@ namespace eval punk {
# but tcl's glob does not respect the case of even the character-class pattern - so this is not a reliable workaround).
#see punk::fglob for a work-in-progress glob implementation which gives us more control over case sensitivity and the case of results on windows.
#track all executables in the path - even those that don't match the binglobs
#use fglob to get the actual case of the executables on windows - as glob seems to return the case as globbed for rather than the actual case on the filesystem in some cases.
#this doesn't run a full 'file normalize' on the results which affects whether a more efficient internal representation is stored
#fglob with single glob argument should already return a unique list.
set folder_exes [fglob -nocomplain -directory $pnormglob -types {f x} *]
if {[set exactmatch [lsearch -exact $context_commands $exe]] ne ""} {
foreach nc $ncmatches {
set nc [namespace eval $nscaller [namespace origin $nc]]
if {$nc eq $exactmatch} {
lappend conflicts $ERR$nc$RST
} else {
lappend conflicts "$WRN$nc$RST"
}
}
} else {
foreach nc $ncmatches {
set nc [namespace eval $nscaller [namespace origin $nc]]
lappend conflicts "$WRN$nc$RST"
}
}
}
}
} else {
#check for any exact matches in context_commands
if {$exe in $context_commands} {
lappend conflicts $ERR$exe$RST
}
}
if {$is_overshadowed} {
lappend display_executables "$SDW$exe$RST"
} else {
lappend display_executables $exe
}
}
} else {
#executable not found in bin_info dict - this shouldn't happen - but if it does we will just treat it as not overshadowed and include it in the display.
lappend thisrow "" ;#don't show conflict info for duplicate paths - as the user should tidy up the PATH to remove duplicates, and the conflict info will be the same as the original path entry.
}
if {[llength $matched_paths] < [llength $all_paths]} {
#if there is any filtering of paths - then we want to show all these paths whether or not there are any matches for binglobs
if {$p in $matched_paths} {
lappend rows $thisrow
}
} else {
#no specific filtering of paths - so only show rows where there are matches for binglobs
if {[lsearch -exact $binglobs "*"] >= 0} {
lappend rows $thisrow
} else {
#end-1 is the executables column.
#if there are no matches for binglobs then we'll hide the row.
if {[string length [lindex $thisrow end-1]] > 0} {
lappend rows $thisrow
}
}
}
incr pidx
}
set t [textblock::table -return tableobject -rows $rows -headers $headers]
#experiment with const for a regex - seems to make no difference to performance - but it does make it clear that the regex is not intended to be modified at runtime
if {[catch {const re_ansi_split $re_ansi_detect}]} {
#tcl 9 has const but tcl 8 doesn't - so we just set it as a normal variable
variable re_ansi_split
set re_ansi_split $re_ansi_detect
}
variable re_ansi_split_multi
if {[string first (?x) $re_ansi_split] == 0} {
set re_ansi_split_multi "(?x)(?:[string range ${re_ansi_split} 4 end])+"
#micro optimisations on split_codes to avoid function calls and make re var local tend to yield very little benefit (sub uS diff on calls that commonly take 10s/100s of uSeconds)
#like split_codes - but each ansi-escape is split out separately (with empty string of plaintext between codes so even/odd indices for plain ansi still holds)
#- the slightly simpler regex than split_codes means that it will be slightly faster than keeping the codes grouped.
#- the regex is slighly simpler than for split_codes - but split_codes is faster when there are consecutive codes.
#review -solo 1 vs -type none ? conflicting values?
tcl::dict::set spec_merged $spec $specval
}
-mincap - -maxcap {
#todo - allow as default for @leaders, @opts and @values when default -type there is regex or regexp?
#only applies to type regex
set tp [tcl::dict::get $spec_merged -type]
if {![string match *regex* $tp]} {
error "punk::args::resolve - invalid use of '$spec' key for argument '$argname'. '$spec' only applies to arguments with a type of regex or regexp. argument has type '$tp' @id:$DEF_definition_id"
}
tcl::dict::set spec_merged $spec $specval
}
-range {
#allow simple case to be specified without additional list wrapping
set litinfo [string range $tp 7 end] ;#get bracketed part if of form literal(xxx)
set match [lindex $tp_alternative 1]
set match [lindex $tp_alternative 1] ;#was bracketed part if of form literal(xxx)
if {$v eq $match} {
set alloc_ok 1
ledit all_remaining end end
if {![dict get $ARG_INFO $clausename -multiple]} {
if {!$clause_is_multiple} {
ledit tailnames end end
}
#the type (or one of the possible type alternates) matched a literal
break
}
}
literalprefix {
set prefix_of [lindex $tp_alternative 1]
#get list of literal and literalprefix values in the current list of tp_alternatives so we can construct list of alternatives for tcl::prefix::match prefix calculation.
#todo - consider if this clause also has -choices {abc def} - we should support those as well here as literal matches for the purposes of calculating the prefix match.
# (this is somewhat of an edge case but sometimes it's useful to specify a -type when -choices is used with -choicerestricted false, to allow only specific values not in the choices list.)
set comparelist [list]
foreach alt $tp_alternatives {
switch -exact -- [lindex $alt 0] {
literal - literalprefix {
lappend comparelist [lindex $alt 1]
}
}
}
set fullmatch [tcl::prefix::match -error "" $comparelist $v]
if {$fullmatch eq $prefix_of} {
set alloc_ok 1
ledit all_remaining end end
if {!$clause_is_multiple} {
ledit tailnames end end
}
break
}
}
stringstartswith {
set pfx [lindex $tp_alternative 1]
if {[string match "$pfx*" $v]} {
set alloc_ok 1
set alloc_ok 1
ledit all_remaining end end
if {![dict get $ARG_INFO $clausename -multiple]} {
#optional -mincap and -maxcap specify number of allowed subexpressions(capture groups) present in regex
set num_caps [lindex $re_about_msg 0]
set mincap 0 ;#default
set maxcap -1 ;#default -1 for unlimited
if {[dict exists $thisarg_checks -mincap]} {
set mincap [dict get $thisarg_checks -mincap]
}
if {[dict exists $thisarg_checks -maxcap]} {
set maxcap [dict get $thisarg_checks -maxcap]
}
if {$maxcap == -1 && $mincap == 0} {
#no cap limits - just accept the regex as valid
lset clause_results $c_idx $a_idx 1
break
} else {
#we have at least one cap limit - we need to count the number of subexpressions in the regex and check it against the limits
if {$maxcap == -1} {
#unlimited maxcap - just check mincap
if {$num_caps < $mincap} {
set msg "$argclass $argname for %caller% requires type regexp with at least $mincap capture groups. Received regex has only $num_caps capture groups. Regex: '$e_check'"
set msg "$argclass $argname for %caller% requires type regexp with at least $mincap capture groups. Received regex has only $num_caps capture groups. Regex: '$e_check'"
set msg "$argclass $argname for %caller% requires type regexp with no more than $maxcap capture groups. Received regex has $num_caps capture groups. Regex: '$e_check'"
#see comments in existingpath/existingfile/existingdirectory case about the challenges of validating filesystem paths in a general way that works across platforms and use cases.
if {[tcl::string::length $e_check]==0 || [string first \0 $e_check] >= 0} {
set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a path, file or directory"
#ideally we want to define callback validation functions that can work not just on a single argument at a time.
#e.g for testing that 2 file arguments do or don't refer to the same file or are in same directory or same filesystem etc.
#we have to support file and directory names on all platforms - and even characters illegal on a filesystem/platform may need to be passed.
#For example a file/folder may be created with an illegal name on a platform (or mounted on it) and be mapped to another string on the filesystem
#- yet it may remain accessible to commands such as file stat etc via the string with 'illegal' characters as well as its underlying stored (mapped) name.
#review - many absolute paths are not strictly portable when considered as a whole e.g /usr/local/bin c:/test
#- but the idea was more about the directory and file name components being portable excluding the first component.
#this concept may need work as it's unintuitive what it means to be a portable file/directory vs not.
#what about windows specific paths such as //?/ //./ or UNC paths?
if {[tcl::string::length $e_check]==0 || [string first \0 $e_check] >= 0 || [punk::winpath::illegalname_test $e_check]} {
set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a portable file or directory (must pass punk::winpath::illegalname_test)"
set leadertypelist [tcl::dict::get $argstate $leadername -type]
set leadertypelist [tcl::dict::get $argstate $leadername -type] ;#often a single type, but can be a list of types (possibly with some optional) for a type that is a clause accepting multiple values.
set leader_clause_size [llength $leadertypelist]
set assign_d [_get_dict_can_assign_value $ldridx $leaders $nameidx $LEADER_NAMES $leadernames_received $formdict]
#not quite right.. this sets the -type for all clauses - but they should run independently
#e.g if expr {} elseif 2 {script2} elseif 3 then {script3} (where elseif clause defined as "literal(elseif) expr ?literal(then)? script")
#the elseif 2 {script2} will raise an error because the newtypelist from elseif 3 then {script3} overwrote the newtypelist where then was given the type ?omitted-...?
#not quite right.. this modifies the -type for all clauses with this name - but for -multiple true each instance should really be considered separately.
#e.g when a subelement-containing clause is allowed to appear multiple times (-multiple true)
# - we may hava a situation where the supplied arguments do and don't omit optional subelements,
# and the newtypelist from one clause may overwrite the newtypelist from the other clause where the optional subelement was omitted in one arg, but not in the other arg.
# - if expr {} elseif 2 {script2} elseif 3 then {script3}
# - (where elseif clause defined as "literal(elseif) expr ?literal(then)? script")
# The elseif 2 {script2} will reassign the type as "literal(elseif) expr ?omitted-literal(then)? script"
# when the elseif 3 then {script3} is processed, 'then' is now considered against the type ?ommitted-literal(then)?
#which (as a non-recognised type is therefore not validated ) will then
# allow any value instead of 'then' to pass.
tcl::dict::set argstate $leadername -type $newtypelist ;#(possible ?omitted-<type>? and ?defaulted-<type>? entries
#see argument_clause_typestate in value processing loop below for more handling of this issue regarding -multiple true clauses with optional subelements
#todo - synchronize with value processing loop below
#- consider refactor to a common procedure for handling this issue of tracking updated typelist state for optional subelements in -multiple true clauses
#incorrect -don't update default -type info.
#tcl::dict::set argstate $leadername -type $newtypelist ;#(possible ?omitted-<type>? and ?defaulted-<type>? entries
}
if {[tcl::dict::get $argstate $leadername -multiple]} {
if {[dict exists $argument_clause_typestate $argname]} {
#lookup saved newtypelist (argument_clause_typelist) from can_assign_value result where some optionals were given type ?omitted-<tp>? or ?defaulted-<tp>?
#lookup saved newtypelist (argument_clause_typelist) from can_assign_value result where some optionals were given type ?omitted-<tp>? or ?defaulted-<tp>? or ?validated-<tp>?.
"Manage the hash table of autoexec commands cached in ::auto_execs."\
-help\
{see also ::punk::auto_exec::rehash}
#---------------------
@form -form {show_or_set}
@opts -min 0 -max 0
@values -min 0 -max -1
name -type string -multiple 1 -optional 1 -default {} -help\
"One or more autoexec command names to set.
If no names are provided, then all autoexec commands in the hash table will be shown."
#---------------------
@form -form {rehash}
@opts -min 1 -max 1
-r -type none -optional 0 -help\
"Clear autoexec commands from the hash table"
@values -min 0 -max 0
#---------------------
@form -form {test}
@opts
-t -type none -optional 0 -default "" -help\
"The name of the autoexec command name to display."
@values -min 1 -max -1
name -type string -multiple 1 -help\
"One or more autoexec command names to display information for.
If only a single name is provided, then the output will be the raw command string
associated with that autoexec command in the hash table.
If multiple names are provided, then the output will be a string containing each
name and its associated command string on a separate line."
#---------------------
@form -form {delete}
@opts
-d -type none -optional 0 -help\
"Delete specified autoexec commands from the hash table."
@values -min 1 -max -1
name -type string -multiple 1 -help\
"One or more autoexec command names to delete from the hash table."
#---------------------
#todo?
#-p <path> <name> (manually assign)
#-l (build a list of hash -p <path> <name> entries for all autoexec commands that can be used in a script to pre-populate the hash table without needing to call auto_execok for each command at runtime)
#---------------------
@form -form {help}
@opts -min 1 -max 1 -anyopts 1
--help -type none -optional 0 -help\
"Display usage information for this command."
@values -min 0 -max -1
ignored -type any -multiple 1 -optional 1 -help\
"Additional arguments that are ignored when --help is used"
}]
}
proc hash {args} {
set arg1 [lindex $args 0]
#select parsing form based on first argument
switch -- $arg1 {
-r {
set form rehash
}
-t {
set form test
}
-d {
set form delete
}
--help {
set form help
}
default {
#like bash in this context, we won't allow an option-like entry to be treated as an executable name
set argd [punk::args::parse $args -form $form withid ::punk::auto_exec::hash]
lassign [dict values $argd] _leaders opts values received
global auto_execs
switch -- $form {
rehash {
unset -nocomplain auto_execs
}
test {
#like bash - we'll provide only the path if there is a single name provided, but if there are multiple names we'll provide both the name and path for each.
set renamed ${routinens}::${routinetail}_[clock clicks] ;#clock clicks unlikely to collide when not directly consecutive such as: list [clock clicks] [clock clicks]
set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split seems to account for a large portion of the time taken to run this function.
set r [binary scan $lenfield su count_chars] ;# su is for unsigned short in little endian order
set string_value ""
if {[Header_Has_LinkFlag $contents "IsUnicode"]} {
#string is UTF-16LE encoded
#string is UTF-16LE encoded - we have this encoding available in tcl 9+ - but not in 8.6
set numbytes [expr {2 * $count_chars}]
set string_bytes [string range $contents $start+2 [expr {$start + 2 + $numbytes - 1}]]
#consider using tcl encoding convertfrom utf-16le instead of manually parsing the UTF-16LE bytes - this would be more robust and handle edge cases better (e.g. surrogate pairs, non-BMP characters, etc.)
set string_value [encoding convertfrom utf-16le $string_bytes]
#for {set i 0} {$i < [string length $string_bytes]} {
# set char_bytes [string range $string_bytes $i [expr {$i + 1}]]
# set r [binary scan $char_bytes su char] ;# s for unsigned short
# append string_value [format %c $char]
# incr i 1 ;# skip the next byte since it's part of the UTF-16LE encoding
#}
#use tcl encoding convertfrom utf-16le when we can instead of manually parsing the UTF-16LE bytes
#- this should be more robust and handle edge cases better (e.g. surrogate pairs, non-BMP characters, etc.)
if {[catch {set string_value [encoding convertfrom utf-16le $string_bytes]} err]} {
"Join blocks of text line by line but don't add padding on each line to enforce uniform width.
Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner.
This version is a thin wrapper around split and join for the common case of joining blocks without any options,
and is intended to avoid the overhead of argument parsing.
"
@values
blocks -type any -multiple 1
}
proc ::textblock::join_basic_raw {args} {
#do not use any argument parsing libs - this is intended as a thin wrapper around split and join for the common case of joining blocks without any options,
#and we want to avoid the overhead of argument parsing.
#no options. -*, -- are legimate blocks
set blocklists [lrepeat [llength $args] ""]
set blocklengths [lrepeat [expr {[llength $args]+1}] 0] ;#add 1 to ensure never empty - used only for rowcount max calc
"Display PATH executable shadowing and conflicts with TCL commands"\
-help\
{Introspection of the PATH environment variable.
This tool will examine executables within each PATH entry and show which binaries
are overshadowed by earlier PATH entries. It can also be used to examine the contents of each PATH entry, and to filter results using glob patterns."
are overshadowed by earlier PATH entries.
It can also be used to examine the contents of each PATH entry, and to filter results using glob patterns.
${[punk::args::helpers::example {
#show all executables in all PATH entries
punk::path
#show all executables in all PATH entries that contain 'Windows' in the path
punk::path -pathglob *Windows*
#show all executables in all PATH entries that contain 'scoop' in the path,
#and filter the executables to show only those that are named dir, ls or start with 'ca'
punk::path -pathglob *scoop* dir ls ca*
#show all executables that conflict with TCL commands starting with 'a' in the current namespace.
punk::path {*}[nscommandlist a*]
#show all executables that conflict with TCL commands resolvable from the current namespace.
punk::path {*}[info commands]
}]}
see also the punk::auto_exec package.
}
@opts
-binglobs -type list -default {*} -help "glob pattern to filter results. Default '*' to include all entries."
-pathglob -type string -default {*} -multiple true -help "Case insensitive glob pattern to filter path entries. Default '*' to include all PATH directories."
@values -min 0 -max -1
glob -type string -default {*} -multiple true -optional 1 -help "Case insensitive glob pattern to filter path entries. Default '*' to include all PATH directories."
binglob -type list -default {*} -multiple true -optional 1 -help "glob pattern to filter results. Default '*' to include all entries."
}
}
variable d_path_info
variable d_bin_info
variable d_index_executables
#there is still a potential conflict regarding auto_execok on windows - which has some cmd.exe builtins as auto-executable
#- but these are not actually executable files on the filesystem - so they won't be found by our path search
#- but they will be found when not masked by a tcl command.
proc path {args} {
variable d_path_info
variable d_bin_info
variable d_index_executables
set is_windows [expr {$::tcl_platform(platform) eq "windows"}]
set argd [punk::args::parse $args withid ::punk::path]
lassign [dict values $argd] leaders opts values received
set binglobs [dict get $opts -binglobs]
set globs [dict get $values glob]
set pathglobs [dict get $opts -pathglob]
set binglobs [dict get $values binglob]
if {$::tcl_platform(platform) eq "windows"} {
set sep ";"
} else {
@ -6299,14 +6333,18 @@ namespace eval punk {
set sep ":"
}
set all_paths [split [string trimright $::env(PATH) $sep] $sep]
set filtered_paths $all_paths
if {[llength $globs]} {
set filtered_paths [list]
foreach p $all_paths {
foreach g $globs {
if {[string match -nocase $g $p]} {
lappend filtered_paths $p
break
if {[llength $pathglobs]} {
if {[lsearch -exact $pathglobs "*"] >= 0} {
#if we have a wildcard glob then the others are irrelevant - we want to match all paths
set matched_paths $all_paths
} else {
set matched_paths [list]
foreach p $all_paths {
foreach pg $pathglobs {
if {[string match -nocase $pg $p]} {
lappend matched_paths $p
break
}
}
}
}
@ -6344,6 +6382,60 @@ namespace eval punk {
#and the actual executable names (with case and extensions as they appear on the filesystem). We will also build a
#dict keyed by path index which contains the list of executables in that path - to make it easy to show which
#executables are overshadowed by which paths.
if {$is_windows} {
#Sometimes PATHEXT includes an entry of just a dot - which means files with no extension are considered executable.
#We need to account for this in our glob pattern.
set pathexts [list]
if {[info exists ::env(PATHEXT)]} {
set env_pathexts [split $::env(PATHEXT) ";"]
#set pathexts [lmap e $env_pathexts {string tolower $e}]
foreach pe $env_pathexts {
if {$pe eq "."} {
continue
}
lappend pathexts [string tolower $pe]
}
} else {
set env_pathexts [list]
#default PATHEXT if not set - according to Microsoft docs
set pathexts [list .com .exe .bat .cmd]
}
foreach bg $binglobs {
set has_pathext 0
foreach pe $pathexts {
if {[string match -nocase "*$pe" $bg]} {
set has_pathext 1
break
}
}
if {!$has_pathext} {
foreach pe $pathexts {
set globext "$bg$pe"
if {$globext ni $binglobs} {
lappend binglobs "$bg$pe"
}
}
}
}
set lc_binglobs [lmap e $binglobs {string tolower $e}]
if {"." in $pathexts} {
foreach bg $binglobs {
set has_pathext 0
foreach pe $pathexts {
if {[string match -nocase "*$pe" $bg]} {
set base [string range $bg 0 [expr {[string length $bg] - [string length $pe] - 1}]]
set has_pathext 1
break
}
}
if {$has_pathext} {
if {[string tolower $base] ni $lc_binglobs} {
lappend binglobs "$base"
}
}
}
}
}
set d_path_info [dict create] ;#key is normalized path (e.g case-insensitive on windows).
set d_bin_info [dict create] ;#key is normalized executable name (e.g case-insensitive on windows, or callable with extensions stripped off).
@ -6355,63 +6447,21 @@ namespace eval punk {
} else {
set pnorm $p
}
if {[string length $pnorm] > 1} {
set lastchar [string index $pnorm end]
if {$lastchar eq "/" || $lastchar eq "\\"} {
set pnorm [string range $pnorm 0 end-1]
}
}
if {![dict exists $d_path_info $pnorm]} {
dict set d_path_info $pnorm [dict create original_paths [list $p] indices [list $path_idx]]
set executables [list]
if {[file isdirectory $p]} {
#get all files that are executable in this path.
#If we don't normalize the path here - then trailing backslashes on windows can cause a problem with the -tail glob returning a leading slash on the executable names.
#also as we don't necessarily normalize the resulting final path with executable - we want the case to be correct.
set pnormglob [file normalize $p]
if {$::tcl_platform(platform) eq "windows"} {
#Sometimes PATHEXT includes an entry of just a dot - which means files with no extension are considered executable.
#We need to account for this in our glob pattern.
set pathexts [list]
if {[info exists ::env(PATHEXT)]} {
set env_pathexts [split $::env(PATHEXT) ";"]
#set pathexts [lmap e $env_pathexts {string tolower $e}]
foreach pe $env_pathexts {
if {$pe eq "."} {
continue
}
lappend pathexts [string tolower $pe]
}
} else {
set env_pathexts [list]
#default PATHEXT if not set - according to Microsoft docs
set pathexts [list .com .exe .bat .cmd]
}
foreach bg $binglobs {
set has_pathext 0
foreach pe $pathexts {
if {[string match -nocase "*$pe" $bg]} {
set has_pathext 1
break
}
}
if {!$has_pathext} {
foreach pe $pathexts {
lappend binglobs "$bg$pe"
}
}
}
set lc_binglobs [lmap e $binglobs {string tolower $e}]
if {"." in $pathexts} {
foreach bg $binglobs {
set has_pathext 0
foreach pe $pathexts {
if {[string match -nocase "*$pe" $bg]} {
set base [string range $bg 0 [expr {[string length $bg] - [string length $pe] - 1}]]
set has_pathext 1
break
}
}
if {$has_pathext} {
if {[string tolower $base] ni $lc_binglobs} {
lappend binglobs "$base"
}
}
}
}
#TCL's glob on windows is case-insensitive, but in some cases return the result with the case as globbed for regardless of the actual case on the filesystem.
#(This seems to occur when the pattern does *not* contain a wildcard and is probably a bug)
@ -6421,34 +6471,51 @@ namespace eval punk {
# but tcl's glob does not respect the case of even the character-class pattern - so this is not a reliable workaround).
#see punk::fglob for a work-in-progress glob implementation which gives us more control over case sensitivity and the case of results on windows.
#track all executables in the path - even those that don't match the binglobs
#use fglob to get the actual case of the executables on windows - as glob seems to return the case as globbed for rather than the actual case on the filesystem in some cases.
#this doesn't run a full 'file normalize' on the results which affects whether a more efficient internal representation is stored
#fglob with single glob argument should already return a unique list.
set folder_exes [fglob -nocomplain -directory $pnormglob -types {f x} *]
if {[set exactmatch [lsearch -exact $context_commands $exe]] ne ""} {
foreach nc $ncmatches {
set nc [namespace eval $nscaller [namespace origin $nc]]
if {$nc eq $exactmatch} {
lappend conflicts $ERR$nc$RST
} else {
lappend conflicts "$WRN$nc$RST"
}
}
} else {
foreach nc $ncmatches {
set nc [namespace eval $nscaller [namespace origin $nc]]
lappend conflicts "$WRN$nc$RST"
}
}
}
}
} else {
#check for any exact matches in context_commands
if {$exe in $context_commands} {
lappend conflicts $ERR$exe$RST
}
}
if {$is_overshadowed} {
lappend display_executables "$SDW$exe$RST"
} else {
lappend display_executables $exe
}
}
} else {
#executable not found in bin_info dict - this shouldn't happen - but if it does we will just treat it as not overshadowed and include it in the display.
lappend thisrow "" ;#don't show conflict info for duplicate paths - as the user should tidy up the PATH to remove duplicates, and the conflict info will be the same as the original path entry.
}
if {[llength $matched_paths] < [llength $all_paths]} {
#if there is any filtering of paths - then we want to show all these paths whether or not there are any matches for binglobs
if {$p in $matched_paths} {
lappend rows $thisrow
}
} else {
#no specific filtering of paths - so only show rows where there are matches for binglobs
if {[lsearch -exact $binglobs "*"] >= 0} {
lappend rows $thisrow
} else {
#end-1 is the executables column.
#if there are no matches for binglobs then we'll hide the row.
if {[string length [lindex $thisrow end-1]] > 0} {
lappend rows $thisrow
}
}
}
incr pidx
}
set t [textblock::table -return tableobject -rows $rows -headers $headers]
#experiment with const for a regex - seems to make no difference to performance - but it does make it clear that the regex is not intended to be modified at runtime
if {[catch {const re_ansi_split $re_ansi_detect}]} {
#tcl 9 has const but tcl 8 doesn't - so we just set it as a normal variable
variable re_ansi_split
set re_ansi_split $re_ansi_detect
}
variable re_ansi_split_multi
if {[string first (?x) $re_ansi_split] == 0} {
set re_ansi_split_multi "(?x)(?:[string range ${re_ansi_split} 4 end])+"
#micro optimisations on split_codes to avoid function calls and make re var local tend to yield very little benefit (sub uS diff on calls that commonly take 10s/100s of uSeconds)
#like split_codes - but each ansi-escape is split out separately (with empty string of plaintext between codes so even/odd indices for plain ansi still holds)
#- the slightly simpler regex than split_codes means that it will be slightly faster than keeping the codes grouped.
#- the regex is slighly simpler than for split_codes - but split_codes is faster when there are consecutive codes.
#review -solo 1 vs -type none ? conflicting values?
tcl::dict::set spec_merged $spec $specval
}
-mincap - -maxcap {
#todo - allow as default for @leaders, @opts and @values when default -type there is regex or regexp?
#only applies to type regex
set tp [tcl::dict::get $spec_merged -type]
if {![string match *regex* $tp]} {
error "punk::args::resolve - invalid use of '$spec' key for argument '$argname'. '$spec' only applies to arguments with a type of regex or regexp. argument has type '$tp' @id:$DEF_definition_id"
}
tcl::dict::set spec_merged $spec $specval
}
-range {
#allow simple case to be specified without additional list wrapping
set litinfo [string range $tp 7 end] ;#get bracketed part if of form literal(xxx)
set match [lindex $tp_alternative 1]
set match [lindex $tp_alternative 1] ;#was bracketed part if of form literal(xxx)
if {$v eq $match} {
set alloc_ok 1
ledit all_remaining end end
if {![dict get $ARG_INFO $clausename -multiple]} {
if {!$clause_is_multiple} {
ledit tailnames end end
}
#the type (or one of the possible type alternates) matched a literal
break
}
}
literalprefix {
set prefix_of [lindex $tp_alternative 1]
#get list of literal and literalprefix values in the current list of tp_alternatives so we can construct list of alternatives for tcl::prefix::match prefix calculation.
#todo - consider if this clause also has -choices {abc def} - we should support those as well here as literal matches for the purposes of calculating the prefix match.
# (this is somewhat of an edge case but sometimes it's useful to specify a -type when -choices is used with -choicerestricted false, to allow only specific values not in the choices list.)
set comparelist [list]
foreach alt $tp_alternatives {
switch -exact -- [lindex $alt 0] {
literal - literalprefix {
lappend comparelist [lindex $alt 1]
}
}
}
set fullmatch [tcl::prefix::match -error "" $comparelist $v]
if {$fullmatch eq $prefix_of} {
set alloc_ok 1
ledit all_remaining end end
if {!$clause_is_multiple} {
ledit tailnames end end
}
break
}
}
stringstartswith {
set pfx [lindex $tp_alternative 1]
if {[string match "$pfx*" $v]} {
set alloc_ok 1
set alloc_ok 1
ledit all_remaining end end
if {![dict get $ARG_INFO $clausename -multiple]} {
#optional -mincap and -maxcap specify number of allowed subexpressions(capture groups) present in regex
set num_caps [lindex $re_about_msg 0]
set mincap 0 ;#default
set maxcap -1 ;#default -1 for unlimited
if {[dict exists $thisarg_checks -mincap]} {
set mincap [dict get $thisarg_checks -mincap]
}
if {[dict exists $thisarg_checks -maxcap]} {
set maxcap [dict get $thisarg_checks -maxcap]
}
if {$maxcap == -1 && $mincap == 0} {
#no cap limits - just accept the regex as valid
lset clause_results $c_idx $a_idx 1
break
} else {
#we have at least one cap limit - we need to count the number of subexpressions in the regex and check it against the limits
if {$maxcap == -1} {
#unlimited maxcap - just check mincap
if {$num_caps < $mincap} {
set msg "$argclass $argname for %caller% requires type regexp with at least $mincap capture groups. Received regex has only $num_caps capture groups. Regex: '$e_check'"
set msg "$argclass $argname for %caller% requires type regexp with at least $mincap capture groups. Received regex has only $num_caps capture groups. Regex: '$e_check'"
set msg "$argclass $argname for %caller% requires type regexp with no more than $maxcap capture groups. Received regex has $num_caps capture groups. Regex: '$e_check'"
#see comments in existingpath/existingfile/existingdirectory case about the challenges of validating filesystem paths in a general way that works across platforms and use cases.
if {[tcl::string::length $e_check]==0 || [string first \0 $e_check] >= 0} {
set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a path, file or directory"
#ideally we want to define callback validation functions that can work not just on a single argument at a time.
#e.g for testing that 2 file arguments do or don't refer to the same file or are in same directory or same filesystem etc.
#we have to support file and directory names on all platforms - and even characters illegal on a filesystem/platform may need to be passed.
#For example a file/folder may be created with an illegal name on a platform (or mounted on it) and be mapped to another string on the filesystem
#- yet it may remain accessible to commands such as file stat etc via the string with 'illegal' characters as well as its underlying stored (mapped) name.
#review - many absolute paths are not strictly portable when considered as a whole e.g /usr/local/bin c:/test
#- but the idea was more about the directory and file name components being portable excluding the first component.
#this concept may need work as it's unintuitive what it means to be a portable file/directory vs not.
#what about windows specific paths such as //?/ //./ or UNC paths?
if {[tcl::string::length $e_check]==0 || [string first \0 $e_check] >= 0 || [punk::winpath::illegalname_test $e_check]} {
set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a portable file or directory (must pass punk::winpath::illegalname_test)"
set leadertypelist [tcl::dict::get $argstate $leadername -type]
set leadertypelist [tcl::dict::get $argstate $leadername -type] ;#often a single type, but can be a list of types (possibly with some optional) for a type that is a clause accepting multiple values.
set leader_clause_size [llength $leadertypelist]
set assign_d [_get_dict_can_assign_value $ldridx $leaders $nameidx $LEADER_NAMES $leadernames_received $formdict]
#not quite right.. this sets the -type for all clauses - but they should run independently
#e.g if expr {} elseif 2 {script2} elseif 3 then {script3} (where elseif clause defined as "literal(elseif) expr ?literal(then)? script")
#the elseif 2 {script2} will raise an error because the newtypelist from elseif 3 then {script3} overwrote the newtypelist where then was given the type ?omitted-...?
#not quite right.. this modifies the -type for all clauses with this name - but for -multiple true each instance should really be considered separately.
#e.g when a subelement-containing clause is allowed to appear multiple times (-multiple true)
# - we may hava a situation where the supplied arguments do and don't omit optional subelements,
# and the newtypelist from one clause may overwrite the newtypelist from the other clause where the optional subelement was omitted in one arg, but not in the other arg.
# - if expr {} elseif 2 {script2} elseif 3 then {script3}
# - (where elseif clause defined as "literal(elseif) expr ?literal(then)? script")
# The elseif 2 {script2} will reassign the type as "literal(elseif) expr ?omitted-literal(then)? script"
# when the elseif 3 then {script3} is processed, 'then' is now considered against the type ?ommitted-literal(then)?
#which (as a non-recognised type is therefore not validated ) will then
# allow any value instead of 'then' to pass.
tcl::dict::set argstate $leadername -type $newtypelist ;#(possible ?omitted-<type>? and ?defaulted-<type>? entries
#see argument_clause_typestate in value processing loop below for more handling of this issue regarding -multiple true clauses with optional subelements
#todo - synchronize with value processing loop below
#- consider refactor to a common procedure for handling this issue of tracking updated typelist state for optional subelements in -multiple true clauses
#incorrect -don't update default -type info.
#tcl::dict::set argstate $leadername -type $newtypelist ;#(possible ?omitted-<type>? and ?defaulted-<type>? entries
}
if {[tcl::dict::get $argstate $leadername -multiple]} {
if {[dict exists $argument_clause_typestate $argname]} {
#lookup saved newtypelist (argument_clause_typelist) from can_assign_value result where some optionals were given type ?omitted-<tp>? or ?defaulted-<tp>?
#lookup saved newtypelist (argument_clause_typelist) from can_assign_value result where some optionals were given type ?omitted-<tp>? or ?defaulted-<tp>? or ?validated-<tp>?.
"Manage the hash table of autoexec commands cached in ::auto_execs."\
-help\
{see also ::punk::auto_exec::rehash}
#---------------------
@form -form {show_or_set}
@opts -min 0 -max 0
@values -min 0 -max -1
name -type string -multiple 1 -optional 1 -default {} -help\
"One or more autoexec command names to set.
If no names are provided, then all autoexec commands in the hash table will be shown."
#---------------------
@form -form {rehash}
@opts -min 1 -max 1
-r -type none -optional 0 -help\
"Clear autoexec commands from the hash table"
@values -min 0 -max 0
#---------------------
@form -form {test}
@opts
-t -type none -optional 0 -default "" -help\
"The name of the autoexec command name to display."
@values -min 1 -max -1
name -type string -multiple 1 -help\
"One or more autoexec command names to display information for.
If only a single name is provided, then the output will be the raw command string
associated with that autoexec command in the hash table.
If multiple names are provided, then the output will be a string containing each
name and its associated command string on a separate line."
#---------------------
@form -form {delete}
@opts
-d -type none -optional 0 -help\
"Delete specified autoexec commands from the hash table."
@values -min 1 -max -1
name -type string -multiple 1 -help\
"One or more autoexec command names to delete from the hash table."
#---------------------
#todo?
#-p <path> <name> (manually assign)
#-l (build a list of hash -p <path> <name> entries for all autoexec commands that can be used in a script to pre-populate the hash table without needing to call auto_execok for each command at runtime)
#---------------------
@form -form {help}
@opts -min 1 -max 1 -anyopts 1
--help -type none -optional 0 -help\
"Display usage information for this command."
@values -min 0 -max -1
ignored -type any -multiple 1 -optional 1 -help\
"Additional arguments that are ignored when --help is used"
}]
}
proc hash {args} {
set arg1 [lindex $args 0]
#select parsing form based on first argument
switch -- $arg1 {
-r {
set form rehash
}
-t {
set form test
}
-d {
set form delete
}
--help {
set form help
}
default {
#like bash in this context, we won't allow an option-like entry to be treated as an executable name
set argd [punk::args::parse $args -form $form withid ::punk::auto_exec::hash]
lassign [dict values $argd] _leaders opts values received
global auto_execs
switch -- $form {
rehash {
unset -nocomplain auto_execs
}
test {
#like bash - we'll provide only the path if there is a single name provided, but if there are multiple names we'll provide both the name and path for each.
"Return a list of the server capabilities last received,
or a boolean indicating if a particular capability was
present."
@cmd -name punk::imap4::proto::has_capability\
-summary\
"List capabilities or test existence of a specific capability."\
-help\
"Returns a list of the server capabilities last received when called
with no argument.
Returns boolean indicating if a particular capability was
present when called with a capability argument. The capability argument is case-insensitive and should be specified in the same form as it would be expected to be received from"
set renamed ${routinens}::${routinetail}_[clock clicks] ;#clock clicks unlikely to collide when not directly consecutive such as: list [clock clicks] [clock clicks]
set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split seems to account for a large portion of the time taken to run this function.
set r [binary scan $lenfield su count_chars] ;# su is for unsigned short in little endian order
set string_value ""
if {[Header_Has_LinkFlag $contents "IsUnicode"]} {
#string is UTF-16LE encoded
#string is UTF-16LE encoded - we have this encoding available in tcl 9+ - but not in 8.6
set numbytes [expr {2 * $count_chars}]
set string_bytes [string range $contents $start+2 [expr {$start + 2 + $numbytes - 1}]]
#consider using tcl encoding convertfrom utf-16le instead of manually parsing the UTF-16LE bytes - this would be more robust and handle edge cases better (e.g. surrogate pairs, non-BMP characters, etc.)
set string_value [encoding convertfrom utf-16le $string_bytes]
#for {set i 0} {$i < [string length $string_bytes]} {
# set char_bytes [string range $string_bytes $i [expr {$i + 1}]]
# set r [binary scan $char_bytes su char] ;# s for unsigned short
# append string_value [format %c $char]
# incr i 1 ;# skip the next byte since it's part of the UTF-16LE encoding
#}
#use tcl encoding convertfrom utf-16le when we can instead of manually parsing the UTF-16LE bytes
#- this should be more robust and handle edge cases better (e.g. surrogate pairs, non-BMP characters, etc.)
if {[catch {set string_value [encoding convertfrom utf-16le $string_bytes]} err]} {
test parse_withdef_value_leading_multiple_not_greedy_with_trailing_literal {Test value clause with leading -multiple true clause is not greedy when trailing literal can be matched}\
"Join blocks of text line by line but don't add padding on each line to enforce uniform width.
Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner.
This version is a thin wrapper around split and join for the common case of joining blocks without any options,
and is intended to avoid the overhead of argument parsing.
"
@values
blocks -type any -multiple 1
}
proc ::textblock::join_basic_raw {args} {
#do not use any argument parsing libs - this is intended as a thin wrapper around split and join for the common case of joining blocks without any options,
#and we want to avoid the overhead of argument parsing.
#no options. -*, -- are legimate blocks
set blocklists [lrepeat [llength $args] ""]
set blocklengths [lrepeat [expr {[llength $args]+1}] 0] ;#add 1 to ensure never empty - used only for rowcount max calc
#Should move to home position and reset ansi SGR when no save data available
#TODO
#?restore without save?
#should move to home position and reset ansi SGR?
#puts stderr "overtype::renderspace cursor_restore without save data available"
}
#If we were inserting prior to hitting the cursor_restore - there could be overflow_right data - generally the overtype functions aren't for inserting - but ansi can enable it
"Display PATH executable shadowing and conflicts with TCL commands"\
-help\
{Introspection of the PATH environment variable.
This tool will examine executables within each PATH entry and show which binaries
are overshadowed by earlier PATH entries. It can also be used to examine the contents of each PATH entry, and to filter results using glob patterns."
are overshadowed by earlier PATH entries.
It can also be used to examine the contents of each PATH entry, and to filter results using glob patterns.
${[punk::args::helpers::example {
#show all executables in all PATH entries
punk::path
#show all executables in all PATH entries that contain 'Windows' in the path
punk::path -pathglob *Windows*
#show all executables in all PATH entries that contain 'scoop' in the path,
#and filter the executables to show only those that are named dir, ls or start with 'ca'
punk::path -pathglob *scoop* dir ls ca*
#show all executables that conflict with TCL commands starting with 'a' in the current namespace.
punk::path {*}[nscommandlist a*]
#show all executables that conflict with TCL commands resolvable from the current namespace.
punk::path {*}[info commands]
}]}
see also the punk::auto_exec package.
}
@opts
-binglobs -type list -default {*} -help "glob pattern to filter results. Default '*' to include all entries."
-pathglob -type string -default {*} -multiple true -help "Case insensitive glob pattern to filter path entries. Default '*' to include all PATH directories."
@values -min 0 -max -1
glob -type string -default {*} -multiple true -optional 1 -help "Case insensitive glob pattern to filter path entries. Default '*' to include all PATH directories."
binglob -type list -default {*} -multiple true -optional 1 -help "glob pattern to filter results. Default '*' to include all entries."
}
}
variable d_path_info
variable d_bin_info
variable d_index_executables
#there is still a potential conflict regarding auto_execok on windows - which has some cmd.exe builtins as auto-executable
#- but these are not actually executable files on the filesystem - so they won't be found by our path search
#- but they will be found when not masked by a tcl command.
proc path {args} {
variable d_path_info
variable d_bin_info
variable d_index_executables
set is_windows [expr {$::tcl_platform(platform) eq "windows"}]
set argd [punk::args::parse $args withid ::punk::path]
lassign [dict values $argd] leaders opts values received
set binglobs [dict get $opts -binglobs]
set globs [dict get $values glob]
set pathglobs [dict get $opts -pathglob]
set binglobs [dict get $values binglob]
if {$::tcl_platform(platform) eq "windows"} {
set sep ";"
} else {
@ -6299,14 +6333,18 @@ namespace eval punk {
set sep ":"
}
set all_paths [split [string trimright $::env(PATH) $sep] $sep]
set filtered_paths $all_paths
if {[llength $globs]} {
set filtered_paths [list]
foreach p $all_paths {
foreach g $globs {
if {[string match -nocase $g $p]} {
lappend filtered_paths $p
break
if {[llength $pathglobs]} {
if {[lsearch -exact $pathglobs "*"] >= 0} {
#if we have a wildcard glob then the others are irrelevant - we want to match all paths
set matched_paths $all_paths
} else {
set matched_paths [list]
foreach p $all_paths {
foreach pg $pathglobs {
if {[string match -nocase $pg $p]} {
lappend matched_paths $p
break
}
}
}
}
@ -6344,6 +6382,60 @@ namespace eval punk {
#and the actual executable names (with case and extensions as they appear on the filesystem). We will also build a
#dict keyed by path index which contains the list of executables in that path - to make it easy to show which
#executables are overshadowed by which paths.
if {$is_windows} {
#Sometimes PATHEXT includes an entry of just a dot - which means files with no extension are considered executable.
#We need to account for this in our glob pattern.
set pathexts [list]
if {[info exists ::env(PATHEXT)]} {
set env_pathexts [split $::env(PATHEXT) ";"]
#set pathexts [lmap e $env_pathexts {string tolower $e}]
foreach pe $env_pathexts {
if {$pe eq "."} {
continue
}
lappend pathexts [string tolower $pe]
}
} else {
set env_pathexts [list]
#default PATHEXT if not set - according to Microsoft docs
set pathexts [list .com .exe .bat .cmd]
}
foreach bg $binglobs {
set has_pathext 0
foreach pe $pathexts {
if {[string match -nocase "*$pe" $bg]} {
set has_pathext 1
break
}
}
if {!$has_pathext} {
foreach pe $pathexts {
set globext "$bg$pe"
if {$globext ni $binglobs} {
lappend binglobs "$bg$pe"
}
}
}
}
set lc_binglobs [lmap e $binglobs {string tolower $e}]
if {"." in $pathexts} {
foreach bg $binglobs {
set has_pathext 0
foreach pe $pathexts {
if {[string match -nocase "*$pe" $bg]} {
set base [string range $bg 0 [expr {[string length $bg] - [string length $pe] - 1}]]
set has_pathext 1
break
}
}
if {$has_pathext} {
if {[string tolower $base] ni $lc_binglobs} {
lappend binglobs "$base"
}
}
}
}
}
set d_path_info [dict create] ;#key is normalized path (e.g case-insensitive on windows).
set d_bin_info [dict create] ;#key is normalized executable name (e.g case-insensitive on windows, or callable with extensions stripped off).
@ -6355,63 +6447,21 @@ namespace eval punk {
} else {
set pnorm $p
}
if {[string length $pnorm] > 1} {
set lastchar [string index $pnorm end]
if {$lastchar eq "/" || $lastchar eq "\\"} {
set pnorm [string range $pnorm 0 end-1]
}
}
if {![dict exists $d_path_info $pnorm]} {
dict set d_path_info $pnorm [dict create original_paths [list $p] indices [list $path_idx]]
set executables [list]
if {[file isdirectory $p]} {
#get all files that are executable in this path.
#If we don't normalize the path here - then trailing backslashes on windows can cause a problem with the -tail glob returning a leading slash on the executable names.
#also as we don't necessarily normalize the resulting final path with executable - we want the case to be correct.
set pnormglob [file normalize $p]
if {$::tcl_platform(platform) eq "windows"} {
#Sometimes PATHEXT includes an entry of just a dot - which means files with no extension are considered executable.
#We need to account for this in our glob pattern.
set pathexts [list]
if {[info exists ::env(PATHEXT)]} {
set env_pathexts [split $::env(PATHEXT) ";"]
#set pathexts [lmap e $env_pathexts {string tolower $e}]
foreach pe $env_pathexts {
if {$pe eq "."} {
continue
}
lappend pathexts [string tolower $pe]
}
} else {
set env_pathexts [list]
#default PATHEXT if not set - according to Microsoft docs
set pathexts [list .com .exe .bat .cmd]
}
foreach bg $binglobs {
set has_pathext 0
foreach pe $pathexts {
if {[string match -nocase "*$pe" $bg]} {
set has_pathext 1
break
}
}
if {!$has_pathext} {
foreach pe $pathexts {
lappend binglobs "$bg$pe"
}
}
}
set lc_binglobs [lmap e $binglobs {string tolower $e}]
if {"." in $pathexts} {
foreach bg $binglobs {
set has_pathext 0
foreach pe $pathexts {
if {[string match -nocase "*$pe" $bg]} {
set base [string range $bg 0 [expr {[string length $bg] - [string length $pe] - 1}]]
set has_pathext 1
break
}
}
if {$has_pathext} {
if {[string tolower $base] ni $lc_binglobs} {
lappend binglobs "$base"
}
}
}
}
#TCL's glob on windows is case-insensitive, but in some cases return the result with the case as globbed for regardless of the actual case on the filesystem.
#(This seems to occur when the pattern does *not* contain a wildcard and is probably a bug)
@ -6421,34 +6471,51 @@ namespace eval punk {
# but tcl's glob does not respect the case of even the character-class pattern - so this is not a reliable workaround).
#see punk::fglob for a work-in-progress glob implementation which gives us more control over case sensitivity and the case of results on windows.
#track all executables in the path - even those that don't match the binglobs
#use fglob to get the actual case of the executables on windows - as glob seems to return the case as globbed for rather than the actual case on the filesystem in some cases.
#this doesn't run a full 'file normalize' on the results which affects whether a more efficient internal representation is stored
#fglob with single glob argument should already return a unique list.
set folder_exes [fglob -nocomplain -directory $pnormglob -types {f x} *]
if {[set exactmatch [lsearch -exact $context_commands $exe]] ne ""} {
foreach nc $ncmatches {
set nc [namespace eval $nscaller [namespace origin $nc]]
if {$nc eq $exactmatch} {
lappend conflicts $ERR$nc$RST
} else {
lappend conflicts "$WRN$nc$RST"
}
}
} else {
foreach nc $ncmatches {
set nc [namespace eval $nscaller [namespace origin $nc]]
lappend conflicts "$WRN$nc$RST"
}
}
}
}
} else {
#check for any exact matches in context_commands
if {$exe in $context_commands} {
lappend conflicts $ERR$exe$RST
}
}
if {$is_overshadowed} {
lappend display_executables "$SDW$exe$RST"
} else {
lappend display_executables $exe
}
}
} else {
#executable not found in bin_info dict - this shouldn't happen - but if it does we will just treat it as not overshadowed and include it in the display.
lappend thisrow "" ;#don't show conflict info for duplicate paths - as the user should tidy up the PATH to remove duplicates, and the conflict info will be the same as the original path entry.
}
if {[llength $matched_paths] < [llength $all_paths]} {
#if there is any filtering of paths - then we want to show all these paths whether or not there are any matches for binglobs
if {$p in $matched_paths} {
lappend rows $thisrow
}
} else {
#no specific filtering of paths - so only show rows where there are matches for binglobs
if {[lsearch -exact $binglobs "*"] >= 0} {
lappend rows $thisrow
} else {
#end-1 is the executables column.
#if there are no matches for binglobs then we'll hide the row.
if {[string length [lindex $thisrow end-1]] > 0} {
lappend rows $thisrow
}
}
}
incr pidx
}
set t [textblock::table -return tableobject -rows $rows -headers $headers]
#experiment with const for a regex - seems to make no difference to performance - but it does make it clear that the regex is not intended to be modified at runtime
if {[catch {const re_ansi_split $re_ansi_detect}]} {
#tcl 9 has const but tcl 8 doesn't - so we just set it as a normal variable
variable re_ansi_split
set re_ansi_split $re_ansi_detect
}
variable re_ansi_split_multi
if {[string first (?x) $re_ansi_split] == 0} {
set re_ansi_split_multi "(?x)(?:[string range ${re_ansi_split} 4 end])+"
#micro optimisations on split_codes to avoid function calls and make re var local tend to yield very little benefit (sub uS diff on calls that commonly take 10s/100s of uSeconds)
#like split_codes - but each ansi-escape is split out separately (with empty string of plaintext between codes so even/odd indices for plain ansi still holds)
#- the slightly simpler regex than split_codes means that it will be slightly faster than keeping the codes grouped.
#- the regex is slighly simpler than for split_codes - but split_codes is faster when there are consecutive codes.
#review -solo 1 vs -type none ? conflicting values?
tcl::dict::set spec_merged $spec $specval
}
-mincap - -maxcap {
#todo - allow as default for @leaders, @opts and @values when default -type there is regex or regexp?
#only applies to type regex
set tp [tcl::dict::get $spec_merged -type]
if {![string match *regex* $tp]} {
error "punk::args::resolve - invalid use of '$spec' key for argument '$argname'. '$spec' only applies to arguments with a type of regex or regexp. argument has type '$tp' @id:$DEF_definition_id"
}
tcl::dict::set spec_merged $spec $specval
}
-range {
#allow simple case to be specified without additional list wrapping
set litinfo [string range $tp 7 end] ;#get bracketed part if of form literal(xxx)
set match [lindex $tp_alternative 1]
set match [lindex $tp_alternative 1] ;#was bracketed part if of form literal(xxx)
if {$v eq $match} {
set alloc_ok 1
ledit all_remaining end end
if {![dict get $ARG_INFO $clausename -multiple]} {
if {!$clause_is_multiple} {
ledit tailnames end end
}
#the type (or one of the possible type alternates) matched a literal
break
}
}
literalprefix {
set prefix_of [lindex $tp_alternative 1]
#get list of literal and literalprefix values in the current list of tp_alternatives so we can construct list of alternatives for tcl::prefix::match prefix calculation.
#todo - consider if this clause also has -choices {abc def} - we should support those as well here as literal matches for the purposes of calculating the prefix match.
# (this is somewhat of an edge case but sometimes it's useful to specify a -type when -choices is used with -choicerestricted false, to allow only specific values not in the choices list.)
set comparelist [list]
foreach alt $tp_alternatives {
switch -exact -- [lindex $alt 0] {
literal - literalprefix {
lappend comparelist [lindex $alt 1]
}
}
}
set fullmatch [tcl::prefix::match -error "" $comparelist $v]
if {$fullmatch eq $prefix_of} {
set alloc_ok 1
ledit all_remaining end end
if {!$clause_is_multiple} {
ledit tailnames end end
}
break
}
}
stringstartswith {
set pfx [lindex $tp_alternative 1]
if {[string match "$pfx*" $v]} {
set alloc_ok 1
set alloc_ok 1
ledit all_remaining end end
if {![dict get $ARG_INFO $clausename -multiple]} {
#optional -mincap and -maxcap specify number of allowed subexpressions(capture groups) present in regex
set num_caps [lindex $re_about_msg 0]
set mincap 0 ;#default
set maxcap -1 ;#default -1 for unlimited
if {[dict exists $thisarg_checks -mincap]} {
set mincap [dict get $thisarg_checks -mincap]
}
if {[dict exists $thisarg_checks -maxcap]} {
set maxcap [dict get $thisarg_checks -maxcap]
}
if {$maxcap == -1 && $mincap == 0} {
#no cap limits - just accept the regex as valid
lset clause_results $c_idx $a_idx 1
break
} else {
#we have at least one cap limit - we need to count the number of subexpressions in the regex and check it against the limits
if {$maxcap == -1} {
#unlimited maxcap - just check mincap
if {$num_caps < $mincap} {
set msg "$argclass $argname for %caller% requires type regexp with at least $mincap capture groups. Received regex has only $num_caps capture groups. Regex: '$e_check'"
set msg "$argclass $argname for %caller% requires type regexp with at least $mincap capture groups. Received regex has only $num_caps capture groups. Regex: '$e_check'"
set msg "$argclass $argname for %caller% requires type regexp with no more than $maxcap capture groups. Received regex has $num_caps capture groups. Regex: '$e_check'"
#see comments in existingpath/existingfile/existingdirectory case about the challenges of validating filesystem paths in a general way that works across platforms and use cases.
if {[tcl::string::length $e_check]==0 || [string first \0 $e_check] >= 0} {
set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a path, file or directory"
#ideally we want to define callback validation functions that can work not just on a single argument at a time.
#e.g for testing that 2 file arguments do or don't refer to the same file or are in same directory or same filesystem etc.
#we have to support file and directory names on all platforms - and even characters illegal on a filesystem/platform may need to be passed.
#For example a file/folder may be created with an illegal name on a platform (or mounted on it) and be mapped to another string on the filesystem
#- yet it may remain accessible to commands such as file stat etc via the string with 'illegal' characters as well as its underlying stored (mapped) name.
#review - many absolute paths are not strictly portable when considered as a whole e.g /usr/local/bin c:/test
#- but the idea was more about the directory and file name components being portable excluding the first component.
#this concept may need work as it's unintuitive what it means to be a portable file/directory vs not.
#what about windows specific paths such as //?/ //./ or UNC paths?
if {[tcl::string::length $e_check]==0 || [string first \0 $e_check] >= 0 || [punk::winpath::illegalname_test $e_check]} {
set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a portable file or directory (must pass punk::winpath::illegalname_test)"
set leadertypelist [tcl::dict::get $argstate $leadername -type]
set leadertypelist [tcl::dict::get $argstate $leadername -type] ;#often a single type, but can be a list of types (possibly with some optional) for a type that is a clause accepting multiple values.
set leader_clause_size [llength $leadertypelist]
set assign_d [_get_dict_can_assign_value $ldridx $leaders $nameidx $LEADER_NAMES $leadernames_received $formdict]
#not quite right.. this sets the -type for all clauses - but they should run independently
#e.g if expr {} elseif 2 {script2} elseif 3 then {script3} (where elseif clause defined as "literal(elseif) expr ?literal(then)? script")
#the elseif 2 {script2} will raise an error because the newtypelist from elseif 3 then {script3} overwrote the newtypelist where then was given the type ?omitted-...?
#not quite right.. this modifies the -type for all clauses with this name - but for -multiple true each instance should really be considered separately.
#e.g when a subelement-containing clause is allowed to appear multiple times (-multiple true)
# - we may hava a situation where the supplied arguments do and don't omit optional subelements,
# and the newtypelist from one clause may overwrite the newtypelist from the other clause where the optional subelement was omitted in one arg, but not in the other arg.
# - if expr {} elseif 2 {script2} elseif 3 then {script3}
# - (where elseif clause defined as "literal(elseif) expr ?literal(then)? script")
# The elseif 2 {script2} will reassign the type as "literal(elseif) expr ?omitted-literal(then)? script"
# when the elseif 3 then {script3} is processed, 'then' is now considered against the type ?ommitted-literal(then)?
#which (as a non-recognised type is therefore not validated ) will then
# allow any value instead of 'then' to pass.
tcl::dict::set argstate $leadername -type $newtypelist ;#(possible ?omitted-<type>? and ?defaulted-<type>? entries
#see argument_clause_typestate in value processing loop below for more handling of this issue regarding -multiple true clauses with optional subelements
#todo - synchronize with value processing loop below
#- consider refactor to a common procedure for handling this issue of tracking updated typelist state for optional subelements in -multiple true clauses
#incorrect -don't update default -type info.
#tcl::dict::set argstate $leadername -type $newtypelist ;#(possible ?omitted-<type>? and ?defaulted-<type>? entries
}
if {[tcl::dict::get $argstate $leadername -multiple]} {
if {[dict exists $argument_clause_typestate $argname]} {
#lookup saved newtypelist (argument_clause_typelist) from can_assign_value result where some optionals were given type ?omitted-<tp>? or ?defaulted-<tp>?
#lookup saved newtypelist (argument_clause_typelist) from can_assign_value result where some optionals were given type ?omitted-<tp>? or ?defaulted-<tp>? or ?validated-<tp>?.
"Manage the hash table of autoexec commands cached in ::auto_execs."\
-help\
{see also ::punk::auto_exec::rehash}
#---------------------
@form -form {show_or_set}
@opts -min 0 -max 0
@values -min 0 -max -1
name -type string -multiple 1 -optional 1 -default {} -help\
"One or more autoexec command names to set.
If no names are provided, then all autoexec commands in the hash table will be shown."
#---------------------
@form -form {rehash}
@opts -min 1 -max 1
-r -type none -optional 0 -help\
"Clear autoexec commands from the hash table"
@values -min 0 -max 0
#---------------------
@form -form {test}
@opts
-t -type none -optional 0 -default "" -help\
"The name of the autoexec command name to display."
@values -min 1 -max -1
name -type string -multiple 1 -help\
"One or more autoexec command names to display information for.
If only a single name is provided, then the output will be the raw command string
associated with that autoexec command in the hash table.
If multiple names are provided, then the output will be a string containing each
name and its associated command string on a separate line."
#---------------------
@form -form {delete}
@opts
-d -type none -optional 0 -help\
"Delete specified autoexec commands from the hash table."
@values -min 1 -max -1
name -type string -multiple 1 -help\
"One or more autoexec command names to delete from the hash table."
#---------------------
#todo?
#-p <path> <name> (manually assign)
#-l (build a list of hash -p <path> <name> entries for all autoexec commands that can be used in a script to pre-populate the hash table without needing to call auto_execok for each command at runtime)
#---------------------
@form -form {help}
@opts -min 1 -max 1 -anyopts 1
--help -type none -optional 0 -help\
"Display usage information for this command."
@values -min 0 -max -1
ignored -type any -multiple 1 -optional 1 -help\
"Additional arguments that are ignored when --help is used"
}]
}
proc hash {args} {
set arg1 [lindex $args 0]
#select parsing form based on first argument
switch -- $arg1 {
-r {
set form rehash
}
-t {
set form test
}
-d {
set form delete
}
--help {
set form help
}
default {
#like bash in this context, we won't allow an option-like entry to be treated as an executable name
set argd [punk::args::parse $args -form $form withid ::punk::auto_exec::hash]
lassign [dict values $argd] _leaders opts values received
global auto_execs
switch -- $form {
rehash {
unset -nocomplain auto_execs
}
test {
#like bash - we'll provide only the path if there is a single name provided, but if there are multiple names we'll provide both the name and path for each.
set renamed ${routinens}::${routinetail}_[clock clicks] ;#clock clicks unlikely to collide when not directly consecutive such as: list [clock clicks] [clock clicks]
set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split seems to account for a large portion of the time taken to run this function.
set r [binary scan $lenfield su count_chars] ;# su is for unsigned short in little endian order
set string_value ""
if {[Header_Has_LinkFlag $contents "IsUnicode"]} {
#string is UTF-16LE encoded
#string is UTF-16LE encoded - we have this encoding available in tcl 9+ - but not in 8.6
set numbytes [expr {2 * $count_chars}]
set string_bytes [string range $contents $start+2 [expr {$start + 2 + $numbytes - 1}]]
#consider using tcl encoding convertfrom utf-16le instead of manually parsing the UTF-16LE bytes - this would be more robust and handle edge cases better (e.g. surrogate pairs, non-BMP characters, etc.)
set string_value [encoding convertfrom utf-16le $string_bytes]
#for {set i 0} {$i < [string length $string_bytes]} {
# set char_bytes [string range $string_bytes $i [expr {$i + 1}]]
# set r [binary scan $char_bytes su char] ;# s for unsigned short
# append string_value [format %c $char]
# incr i 1 ;# skip the next byte since it's part of the UTF-16LE encoding
#}
#use tcl encoding convertfrom utf-16le when we can instead of manually parsing the UTF-16LE bytes
#- this should be more robust and handle edge cases better (e.g. surrogate pairs, non-BMP characters, etc.)
if {[catch {set string_value [encoding convertfrom utf-16le $string_bytes]} err]} {
"Join blocks of text line by line but don't add padding on each line to enforce uniform width.
Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner.
This version is a thin wrapper around split and join for the common case of joining blocks without any options,
and is intended to avoid the overhead of argument parsing.
"
@values
blocks -type any -multiple 1
}
proc ::textblock::join_basic_raw {args} {
#do not use any argument parsing libs - this is intended as a thin wrapper around split and join for the common case of joining blocks without any options,
#and we want to avoid the overhead of argument parsing.
#no options. -*, -- are legimate blocks
set blocklists [lrepeat [llength $args] ""]
set blocklengths [lrepeat [expr {[llength $args]+1}] 0] ;#add 1 to ensure never empty - used only for rowcount max calc
#Should move to home position and reset ansi SGR when no save data available
#TODO
#?restore without save?
#should move to home position and reset ansi SGR?
#puts stderr "overtype::renderspace cursor_restore without save data available"
}
#If we were inserting prior to hitting the cursor_restore - there could be overflow_right data - generally the overtype functions aren't for inserting - but ansi can enable it
"Display PATH executable shadowing and conflicts with TCL commands"\
-help\
{Introspection of the PATH environment variable.
This tool will examine executables within each PATH entry and show which binaries
are overshadowed by earlier PATH entries. It can also be used to examine the contents of each PATH entry, and to filter results using glob patterns."
are overshadowed by earlier PATH entries.
It can also be used to examine the contents of each PATH entry, and to filter results using glob patterns.
${[punk::args::helpers::example {
#show all executables in all PATH entries
punk::path
#show all executables in all PATH entries that contain 'Windows' in the path
punk::path -pathglob *Windows*
#show all executables in all PATH entries that contain 'scoop' in the path,
#and filter the executables to show only those that are named dir, ls or start with 'ca'
punk::path -pathglob *scoop* dir ls ca*
#show all executables that conflict with TCL commands starting with 'a' in the current namespace.
punk::path {*}[nscommandlist a*]
#show all executables that conflict with TCL commands resolvable from the current namespace.
punk::path {*}[info commands]
}]}
see also the punk::auto_exec package.
}
@opts
-binglobs -type list -default {*} -help "glob pattern to filter results. Default '*' to include all entries."
-pathglob -type string -default {*} -multiple true -help "Case insensitive glob pattern to filter path entries. Default '*' to include all PATH directories."
@values -min 0 -max -1
glob -type string -default {*} -multiple true -optional 1 -help "Case insensitive glob pattern to filter path entries. Default '*' to include all PATH directories."
binglob -type list -default {*} -multiple true -optional 1 -help "glob pattern to filter results. Default '*' to include all entries."
}
}
variable d_path_info
variable d_bin_info
variable d_index_executables
#there is still a potential conflict regarding auto_execok on windows - which has some cmd.exe builtins as auto-executable
#- but these are not actually executable files on the filesystem - so they won't be found by our path search
#- but they will be found when not masked by a tcl command.
proc path {args} {
variable d_path_info
variable d_bin_info
variable d_index_executables
set is_windows [expr {$::tcl_platform(platform) eq "windows"}]
set argd [punk::args::parse $args withid ::punk::path]
lassign [dict values $argd] leaders opts values received
set binglobs [dict get $opts -binglobs]
set globs [dict get $values glob]
set pathglobs [dict get $opts -pathglob]
set binglobs [dict get $values binglob]
if {$::tcl_platform(platform) eq "windows"} {
set sep ";"
} else {
@ -6299,14 +6333,18 @@ namespace eval punk {
set sep ":"
}
set all_paths [split [string trimright $::env(PATH) $sep] $sep]
set filtered_paths $all_paths
if {[llength $globs]} {
set filtered_paths [list]
foreach p $all_paths {
foreach g $globs {
if {[string match -nocase $g $p]} {
lappend filtered_paths $p
break
if {[llength $pathglobs]} {
if {[lsearch -exact $pathglobs "*"] >= 0} {
#if we have a wildcard glob then the others are irrelevant - we want to match all paths
set matched_paths $all_paths
} else {
set matched_paths [list]
foreach p $all_paths {
foreach pg $pathglobs {
if {[string match -nocase $pg $p]} {
lappend matched_paths $p
break
}
}
}
}
@ -6344,6 +6382,60 @@ namespace eval punk {
#and the actual executable names (with case and extensions as they appear on the filesystem). We will also build a
#dict keyed by path index which contains the list of executables in that path - to make it easy to show which
#executables are overshadowed by which paths.
if {$is_windows} {
#Sometimes PATHEXT includes an entry of just a dot - which means files with no extension are considered executable.
#We need to account for this in our glob pattern.
set pathexts [list]
if {[info exists ::env(PATHEXT)]} {
set env_pathexts [split $::env(PATHEXT) ";"]
#set pathexts [lmap e $env_pathexts {string tolower $e}]
foreach pe $env_pathexts {
if {$pe eq "."} {
continue
}
lappend pathexts [string tolower $pe]
}
} else {
set env_pathexts [list]
#default PATHEXT if not set - according to Microsoft docs
set pathexts [list .com .exe .bat .cmd]
}
foreach bg $binglobs {
set has_pathext 0
foreach pe $pathexts {
if {[string match -nocase "*$pe" $bg]} {
set has_pathext 1
break
}
}
if {!$has_pathext} {
foreach pe $pathexts {
set globext "$bg$pe"
if {$globext ni $binglobs} {
lappend binglobs "$bg$pe"
}
}
}
}
set lc_binglobs [lmap e $binglobs {string tolower $e}]
if {"." in $pathexts} {
foreach bg $binglobs {
set has_pathext 0
foreach pe $pathexts {
if {[string match -nocase "*$pe" $bg]} {
set base [string range $bg 0 [expr {[string length $bg] - [string length $pe] - 1}]]
set has_pathext 1
break
}
}
if {$has_pathext} {
if {[string tolower $base] ni $lc_binglobs} {
lappend binglobs "$base"
}
}
}
}
}
set d_path_info [dict create] ;#key is normalized path (e.g case-insensitive on windows).
set d_bin_info [dict create] ;#key is normalized executable name (e.g case-insensitive on windows, or callable with extensions stripped off).
@ -6355,63 +6447,21 @@ namespace eval punk {
} else {
set pnorm $p
}
if {[string length $pnorm] > 1} {
set lastchar [string index $pnorm end]
if {$lastchar eq "/" || $lastchar eq "\\"} {
set pnorm [string range $pnorm 0 end-1]
}
}
if {![dict exists $d_path_info $pnorm]} {
dict set d_path_info $pnorm [dict create original_paths [list $p] indices [list $path_idx]]
set executables [list]
if {[file isdirectory $p]} {
#get all files that are executable in this path.
#If we don't normalize the path here - then trailing backslashes on windows can cause a problem with the -tail glob returning a leading slash on the executable names.
#also as we don't necessarily normalize the resulting final path with executable - we want the case to be correct.
set pnormglob [file normalize $p]
if {$::tcl_platform(platform) eq "windows"} {
#Sometimes PATHEXT includes an entry of just a dot - which means files with no extension are considered executable.
#We need to account for this in our glob pattern.
set pathexts [list]
if {[info exists ::env(PATHEXT)]} {
set env_pathexts [split $::env(PATHEXT) ";"]
#set pathexts [lmap e $env_pathexts {string tolower $e}]
foreach pe $env_pathexts {
if {$pe eq "."} {
continue
}
lappend pathexts [string tolower $pe]
}
} else {
set env_pathexts [list]
#default PATHEXT if not set - according to Microsoft docs
set pathexts [list .com .exe .bat .cmd]
}
foreach bg $binglobs {
set has_pathext 0
foreach pe $pathexts {
if {[string match -nocase "*$pe" $bg]} {
set has_pathext 1
break
}
}
if {!$has_pathext} {
foreach pe $pathexts {
lappend binglobs "$bg$pe"
}
}
}
set lc_binglobs [lmap e $binglobs {string tolower $e}]
if {"." in $pathexts} {
foreach bg $binglobs {
set has_pathext 0
foreach pe $pathexts {
if {[string match -nocase "*$pe" $bg]} {
set base [string range $bg 0 [expr {[string length $bg] - [string length $pe] - 1}]]
set has_pathext 1
break
}
}
if {$has_pathext} {
if {[string tolower $base] ni $lc_binglobs} {
lappend binglobs "$base"
}
}
}
}
#TCL's glob on windows is case-insensitive, but in some cases return the result with the case as globbed for regardless of the actual case on the filesystem.
#(This seems to occur when the pattern does *not* contain a wildcard and is probably a bug)
@ -6421,34 +6471,51 @@ namespace eval punk {
# but tcl's glob does not respect the case of even the character-class pattern - so this is not a reliable workaround).
#see punk::fglob for a work-in-progress glob implementation which gives us more control over case sensitivity and the case of results on windows.
#track all executables in the path - even those that don't match the binglobs
#use fglob to get the actual case of the executables on windows - as glob seems to return the case as globbed for rather than the actual case on the filesystem in some cases.
#this doesn't run a full 'file normalize' on the results which affects whether a more efficient internal representation is stored
#fglob with single glob argument should already return a unique list.
set folder_exes [fglob -nocomplain -directory $pnormglob -types {f x} *]
if {[set exactmatch [lsearch -exact $context_commands $exe]] ne ""} {
foreach nc $ncmatches {
set nc [namespace eval $nscaller [namespace origin $nc]]
if {$nc eq $exactmatch} {
lappend conflicts $ERR$nc$RST
} else {
lappend conflicts "$WRN$nc$RST"
}
}
} else {
foreach nc $ncmatches {
set nc [namespace eval $nscaller [namespace origin $nc]]
lappend conflicts "$WRN$nc$RST"
}
}
}
}
} else {
#check for any exact matches in context_commands
if {$exe in $context_commands} {
lappend conflicts $ERR$exe$RST
}
}
if {$is_overshadowed} {
lappend display_executables "$SDW$exe$RST"
} else {
lappend display_executables $exe
}
}
} else {
#executable not found in bin_info dict - this shouldn't happen - but if it does we will just treat it as not overshadowed and include it in the display.
lappend thisrow "" ;#don't show conflict info for duplicate paths - as the user should tidy up the PATH to remove duplicates, and the conflict info will be the same as the original path entry.
}
if {[llength $matched_paths] < [llength $all_paths]} {
#if there is any filtering of paths - then we want to show all these paths whether or not there are any matches for binglobs
if {$p in $matched_paths} {
lappend rows $thisrow
}
} else {
#no specific filtering of paths - so only show rows where there are matches for binglobs
if {[lsearch -exact $binglobs "*"] >= 0} {
lappend rows $thisrow
} else {
#end-1 is the executables column.
#if there are no matches for binglobs then we'll hide the row.
if {[string length [lindex $thisrow end-1]] > 0} {
lappend rows $thisrow
}
}
}
incr pidx
}
set t [textblock::table -return tableobject -rows $rows -headers $headers]
#experiment with const for a regex - seems to make no difference to performance - but it does make it clear that the regex is not intended to be modified at runtime
if {[catch {const re_ansi_split $re_ansi_detect}]} {
#tcl 9 has const but tcl 8 doesn't - so we just set it as a normal variable
variable re_ansi_split
set re_ansi_split $re_ansi_detect
}
variable re_ansi_split_multi
if {[string first (?x) $re_ansi_split] == 0} {
set re_ansi_split_multi "(?x)(?:[string range ${re_ansi_split} 4 end])+"
#micro optimisations on split_codes to avoid function calls and make re var local tend to yield very little benefit (sub uS diff on calls that commonly take 10s/100s of uSeconds)
#like split_codes - but each ansi-escape is split out separately (with empty string of plaintext between codes so even/odd indices for plain ansi still holds)
#- the slightly simpler regex than split_codes means that it will be slightly faster than keeping the codes grouped.
#- the regex is slighly simpler than for split_codes - but split_codes is faster when there are consecutive codes.
#review -solo 1 vs -type none ? conflicting values?
tcl::dict::set spec_merged $spec $specval
}
-mincap - -maxcap {
#todo - allow as default for @leaders, @opts and @values when default -type there is regex or regexp?
#only applies to type regex
set tp [tcl::dict::get $spec_merged -type]
if {![string match *regex* $tp]} {
error "punk::args::resolve - invalid use of '$spec' key for argument '$argname'. '$spec' only applies to arguments with a type of regex or regexp. argument has type '$tp' @id:$DEF_definition_id"
}
tcl::dict::set spec_merged $spec $specval
}
-range {
#allow simple case to be specified without additional list wrapping
set litinfo [string range $tp 7 end] ;#get bracketed part if of form literal(xxx)
set match [lindex $tp_alternative 1]
set match [lindex $tp_alternative 1] ;#was bracketed part if of form literal(xxx)
if {$v eq $match} {
set alloc_ok 1
ledit all_remaining end end
if {![dict get $ARG_INFO $clausename -multiple]} {
if {!$clause_is_multiple} {
ledit tailnames end end
}
#the type (or one of the possible type alternates) matched a literal
break
}
}
literalprefix {
set prefix_of [lindex $tp_alternative 1]
#get list of literal and literalprefix values in the current list of tp_alternatives so we can construct list of alternatives for tcl::prefix::match prefix calculation.
#todo - consider if this clause also has -choices {abc def} - we should support those as well here as literal matches for the purposes of calculating the prefix match.
# (this is somewhat of an edge case but sometimes it's useful to specify a -type when -choices is used with -choicerestricted false, to allow only specific values not in the choices list.)
set comparelist [list]
foreach alt $tp_alternatives {
switch -exact -- [lindex $alt 0] {
literal - literalprefix {
lappend comparelist [lindex $alt 1]
}
}
}
set fullmatch [tcl::prefix::match -error "" $comparelist $v]
if {$fullmatch eq $prefix_of} {
set alloc_ok 1
ledit all_remaining end end
if {!$clause_is_multiple} {
ledit tailnames end end
}
break
}
}
stringstartswith {
set pfx [lindex $tp_alternative 1]
if {[string match "$pfx*" $v]} {
set alloc_ok 1
set alloc_ok 1
ledit all_remaining end end
if {![dict get $ARG_INFO $clausename -multiple]} {
#optional -mincap and -maxcap specify number of allowed subexpressions(capture groups) present in regex
set num_caps [lindex $re_about_msg 0]
set mincap 0 ;#default
set maxcap -1 ;#default -1 for unlimited
if {[dict exists $thisarg_checks -mincap]} {
set mincap [dict get $thisarg_checks -mincap]
}
if {[dict exists $thisarg_checks -maxcap]} {
set maxcap [dict get $thisarg_checks -maxcap]
}
if {$maxcap == -1 && $mincap == 0} {
#no cap limits - just accept the regex as valid
lset clause_results $c_idx $a_idx 1
break
} else {
#we have at least one cap limit - we need to count the number of subexpressions in the regex and check it against the limits
if {$maxcap == -1} {
#unlimited maxcap - just check mincap
if {$num_caps < $mincap} {
set msg "$argclass $argname for %caller% requires type regexp with at least $mincap capture groups. Received regex has only $num_caps capture groups. Regex: '$e_check'"
set msg "$argclass $argname for %caller% requires type regexp with at least $mincap capture groups. Received regex has only $num_caps capture groups. Regex: '$e_check'"
set msg "$argclass $argname for %caller% requires type regexp with no more than $maxcap capture groups. Received regex has $num_caps capture groups. Regex: '$e_check'"
#see comments in existingpath/existingfile/existingdirectory case about the challenges of validating filesystem paths in a general way that works across platforms and use cases.
if {[tcl::string::length $e_check]==0 || [string first \0 $e_check] >= 0} {
set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a path, file or directory"
#ideally we want to define callback validation functions that can work not just on a single argument at a time.
#e.g for testing that 2 file arguments do or don't refer to the same file or are in same directory or same filesystem etc.
#we have to support file and directory names on all platforms - and even characters illegal on a filesystem/platform may need to be passed.
#For example a file/folder may be created with an illegal name on a platform (or mounted on it) and be mapped to another string on the filesystem
#- yet it may remain accessible to commands such as file stat etc via the string with 'illegal' characters as well as its underlying stored (mapped) name.
#review - many absolute paths are not strictly portable when considered as a whole e.g /usr/local/bin c:/test
#- but the idea was more about the directory and file name components being portable excluding the first component.
#this concept may need work as it's unintuitive what it means to be a portable file/directory vs not.
#what about windows specific paths such as //?/ //./ or UNC paths?
if {[tcl::string::length $e_check]==0 || [string first \0 $e_check] >= 0 || [punk::winpath::illegalname_test $e_check]} {
set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a portable file or directory (must pass punk::winpath::illegalname_test)"
set leadertypelist [tcl::dict::get $argstate $leadername -type]
set leadertypelist [tcl::dict::get $argstate $leadername -type] ;#often a single type, but can be a list of types (possibly with some optional) for a type that is a clause accepting multiple values.
set leader_clause_size [llength $leadertypelist]
set assign_d [_get_dict_can_assign_value $ldridx $leaders $nameidx $LEADER_NAMES $leadernames_received $formdict]
#not quite right.. this sets the -type for all clauses - but they should run independently
#e.g if expr {} elseif 2 {script2} elseif 3 then {script3} (where elseif clause defined as "literal(elseif) expr ?literal(then)? script")
#the elseif 2 {script2} will raise an error because the newtypelist from elseif 3 then {script3} overwrote the newtypelist where then was given the type ?omitted-...?
#not quite right.. this modifies the -type for all clauses with this name - but for -multiple true each instance should really be considered separately.
#e.g when a subelement-containing clause is allowed to appear multiple times (-multiple true)
# - we may hava a situation where the supplied arguments do and don't omit optional subelements,
# and the newtypelist from one clause may overwrite the newtypelist from the other clause where the optional subelement was omitted in one arg, but not in the other arg.
# - if expr {} elseif 2 {script2} elseif 3 then {script3}
# - (where elseif clause defined as "literal(elseif) expr ?literal(then)? script")
# The elseif 2 {script2} will reassign the type as "literal(elseif) expr ?omitted-literal(then)? script"
# when the elseif 3 then {script3} is processed, 'then' is now considered against the type ?ommitted-literal(then)?
#which (as a non-recognised type is therefore not validated ) will then
# allow any value instead of 'then' to pass.
tcl::dict::set argstate $leadername -type $newtypelist ;#(possible ?omitted-<type>? and ?defaulted-<type>? entries
#see argument_clause_typestate in value processing loop below for more handling of this issue regarding -multiple true clauses with optional subelements
#todo - synchronize with value processing loop below
#- consider refactor to a common procedure for handling this issue of tracking updated typelist state for optional subelements in -multiple true clauses
#incorrect -don't update default -type info.
#tcl::dict::set argstate $leadername -type $newtypelist ;#(possible ?omitted-<type>? and ?defaulted-<type>? entries
}
if {[tcl::dict::get $argstate $leadername -multiple]} {
if {[dict exists $argument_clause_typestate $argname]} {
#lookup saved newtypelist (argument_clause_typelist) from can_assign_value result where some optionals were given type ?omitted-<tp>? or ?defaulted-<tp>?
#lookup saved newtypelist (argument_clause_typelist) from can_assign_value result where some optionals were given type ?omitted-<tp>? or ?defaulted-<tp>? or ?validated-<tp>?.
"Manage the hash table of autoexec commands cached in ::auto_execs."\
-help\
{see also ::punk::auto_exec::rehash}
#---------------------
@form -form {show_or_set}
@opts -min 0 -max 0
@values -min 0 -max -1
name -type string -multiple 1 -optional 1 -default {} -help\
"One or more autoexec command names to set.
If no names are provided, then all autoexec commands in the hash table will be shown."
#---------------------
@form -form {rehash}
@opts -min 1 -max 1
-r -type none -optional 0 -help\
"Clear autoexec commands from the hash table"
@values -min 0 -max 0
#---------------------
@form -form {test}
@opts
-t -type none -optional 0 -default "" -help\
"The name of the autoexec command name to display."
@values -min 1 -max -1
name -type string -multiple 1 -help\
"One or more autoexec command names to display information for.
If only a single name is provided, then the output will be the raw command string
associated with that autoexec command in the hash table.
If multiple names are provided, then the output will be a string containing each
name and its associated command string on a separate line."
#---------------------
@form -form {delete}
@opts
-d -type none -optional 0 -help\
"Delete specified autoexec commands from the hash table."
@values -min 1 -max -1
name -type string -multiple 1 -help\
"One or more autoexec command names to delete from the hash table."
#---------------------
#todo?
#-p <path> <name> (manually assign)
#-l (build a list of hash -p <path> <name> entries for all autoexec commands that can be used in a script to pre-populate the hash table without needing to call auto_execok for each command at runtime)
#---------------------
@form -form {help}
@opts -min 1 -max 1 -anyopts 1
--help -type none -optional 0 -help\
"Display usage information for this command."
@values -min 0 -max -1
ignored -type any -multiple 1 -optional 1 -help\
"Additional arguments that are ignored when --help is used"
}]
}
proc hash {args} {
set arg1 [lindex $args 0]
#select parsing form based on first argument
switch -- $arg1 {
-r {
set form rehash
}
-t {
set form test
}
-d {
set form delete
}
--help {
set form help
}
default {
#like bash in this context, we won't allow an option-like entry to be treated as an executable name
set argd [punk::args::parse $args -form $form withid ::punk::auto_exec::hash]
lassign [dict values $argd] _leaders opts values received
global auto_execs
switch -- $form {
rehash {
unset -nocomplain auto_execs
}
test {
#like bash - we'll provide only the path if there is a single name provided, but if there are multiple names we'll provide both the name and path for each.
set renamed ${routinens}::${routinetail}_[clock clicks] ;#clock clicks unlikely to collide when not directly consecutive such as: list [clock clicks] [clock clicks]
set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split seems to account for a large portion of the time taken to run this function.
set r [binary scan $lenfield su count_chars] ;# su is for unsigned short in little endian order
set string_value ""
if {[Header_Has_LinkFlag $contents "IsUnicode"]} {
#string is UTF-16LE encoded
#string is UTF-16LE encoded - we have this encoding available in tcl 9+ - but not in 8.6
set numbytes [expr {2 * $count_chars}]
set string_bytes [string range $contents $start+2 [expr {$start + 2 + $numbytes - 1}]]
#consider using tcl encoding convertfrom utf-16le instead of manually parsing the UTF-16LE bytes - this would be more robust and handle edge cases better (e.g. surrogate pairs, non-BMP characters, etc.)
set string_value [encoding convertfrom utf-16le $string_bytes]
#for {set i 0} {$i < [string length $string_bytes]} {
# set char_bytes [string range $string_bytes $i [expr {$i + 1}]]
# set r [binary scan $char_bytes su char] ;# s for unsigned short
# append string_value [format %c $char]
# incr i 1 ;# skip the next byte since it's part of the UTF-16LE encoding
#}
#use tcl encoding convertfrom utf-16le when we can instead of manually parsing the UTF-16LE bytes
#- this should be more robust and handle edge cases better (e.g. surrogate pairs, non-BMP characters, etc.)
if {[catch {set string_value [encoding convertfrom utf-16le $string_bytes]} err]} {
"Join blocks of text line by line but don't add padding on each line to enforce uniform width.
Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner.
This version is a thin wrapper around split and join for the common case of joining blocks without any options,
and is intended to avoid the overhead of argument parsing.
"
@values
blocks -type any -multiple 1
}
proc ::textblock::join_basic_raw {args} {
#do not use any argument parsing libs - this is intended as a thin wrapper around split and join for the common case of joining blocks without any options,
#and we want to avoid the overhead of argument parsing.
#no options. -*, -- are legimate blocks
set blocklists [lrepeat [llength $args] ""]
set blocklengths [lrepeat [expr {[llength $args]+1}] 0] ;#add 1 to ensure never empty - used only for rowcount max calc
#experiment with const for a regex - seems to make no difference to performance - but it does make it clear that the regex is not intended to be modified at runtime
if {[catch {const re_ansi_split $re_ansi_detect}]} {
#tcl 9 has const but tcl 8 doesn't - so we just set it as a normal variable
variable re_ansi_split
set re_ansi_split $re_ansi_detect
}
variable re_ansi_split_multi
if {[string first (?x) $re_ansi_split] == 0} {
set re_ansi_split_multi "(?x)(?:[string range ${re_ansi_split} 4 end])+"
#micro optimisations on split_codes to avoid function calls and make re var local tend to yield very little benefit (sub uS diff on calls that commonly take 10s/100s of uSeconds)
#like split_codes - but each ansi-escape is split out separately (with empty string of plaintext between codes so even/odd indices for plain ansi still holds)
#- the slightly simpler regex than split_codes means that it will be slightly faster than keeping the codes grouped.
#- the regex is slighly simpler than for split_codes - but split_codes is faster when there are consecutive codes.
set litinfo [string range $tp 7 end] ;#get bracketed part if of form literal(xxx)
set match [lindex $tp_alternative 1]
set match [lindex $tp_alternative 1] ;#was bracketed part if of form literal(xxx)
if {$v eq $match} {
set alloc_ok 1
ledit all_remaining end end
if {![dict get $ARG_INFO $clausename -multiple]} {
if {!$clause_is_multiple} {
ledit tailnames end end
}
#the type (or one of the possible type alternates) matched a literal
break
}
}
literalprefix {
set prefix_of [lindex $tp_alternative 1]
#get list of literal and literalprefix values in the current list of tp_alternatives so we can construct list of alternatives for tcl::prefix::match prefix calculation.
#todo - consider if this clause also has -choices {abc def} - we should support those as well here as literal matches for the purposes of calculating the prefix match.
# (this is somewhat of an edge case but sometimes it's useful to specify a -type when -choices is used with -choicerestricted false, to allow only specific values not in the choices list.)
set comparelist [list]
foreach alt $tp_alternatives {
switch -exact -- [lindex $alt 0] {
literal - literalprefix {
lappend comparelist [lindex $alt 1]
}
}
}
set fullmatch [tcl::prefix::match -error "" $comparelist $v]
if {$fullmatch eq $prefix_of} {
set alloc_ok 1
ledit all_remaining end end
if {!$clause_is_multiple} {
ledit tailnames end end
}
break
}
}
stringstartswith {
set pfx [lindex $tp_alternative 1]
if {[string match "$pfx*" $v]} {
set alloc_ok 1
set alloc_ok 1
ledit all_remaining end end
if {![dict get $ARG_INFO $clausename -multiple]} {
#see comments in existingpath/existingfile/existingdirectory case about the challenges of validating filesystem paths in a general way that works across platforms and use cases.
if {[tcl::string::length $e_check]==0 || [string first \0 $e_check] >= 0} {
set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a path, file or directory"
#ideally we want to define callback validation functions that can work not just on a single argument at a time.
#e.g for testing that 2 file arguments do or don't refer to the same file or are in same directory or same filesystem etc.
#we have to support file and directory names on all platforms - and even characters illegal on a filesystem/platform may need to be passed.
#For example a file/folder may be created with an illegal name on a platform (or mounted on it) and be mapped to another string on the filesystem
#- yet it may remain accessible to commands such as file stat etc via the string with 'illegal' characters as well as its underlying stored (mapped) name.
#review - many absolute paths are not strictly portable when considered as a whole e.g /usr/local/bin c:/test
#- but the idea was more about the directory and file name components being portable excluding the first component.
#this concept may need work as it's unintuitive what it means to be a portable file/directory vs not.
#what about windows specific paths such as //?/ //./ or UNC paths?
if {[tcl::string::length $e_check]==0 || [string first \0 $e_check] >= 0 || [punk::winpath::illegalname_test $e_check]} {
set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a portable file or directory (must pass punk::winpath::illegalname_test)"
set leadertypelist [tcl::dict::get $argstate $leadername -type]
set leadertypelist [tcl::dict::get $argstate $leadername -type] ;#often a single type, but can be a list of types (possibly with some optional) for a type that is a clause accepting multiple values.
set leader_clause_size [llength $leadertypelist]
set assign_d [_get_dict_can_assign_value $ldridx $leaders $nameidx $LEADER_NAMES $leadernames_received $formdict]
#not quite right.. this sets the -type for all clauses - but they should run independently
#e.g if expr {} elseif 2 {script2} elseif 3 then {script3} (where elseif clause defined as "literal(elseif) expr ?literal(then)? script")
#the elseif 2 {script2} will raise an error because the newtypelist from elseif 3 then {script3} overwrote the newtypelist where then was given the type ?omitted-...?
#not quite right.. this modifies the -type for all clauses with this name - but for -multiple true each instance should really be considered separately.
#e.g when a subelement-containing clause is allowed to appear multiple times (-multiple true)
# - we may hava a situation where the supplied arguments do and don't omit optional subelements,
# and the newtypelist from one clause may overwrite the newtypelist from the other clause where the optional subelement was omitted in one arg, but not in the other arg.
# - if expr {} elseif 2 {script2} elseif 3 then {script3}
# - (where elseif clause defined as "literal(elseif) expr ?literal(then)? script")
# The elseif 2 {script2} will reassign the type as "literal(elseif) expr ?omitted-literal(then)? script"
# when the elseif 3 then {script3} is processed, 'then' is now considered against the type ?ommitted-literal(then)?
#which (as a non-recognised type is therefore not validated ) will then
# allow any value instead of 'then' to pass.
#see argument_clause_typestate in value processing loop below for more handling of this issue regarding -multiple true clauses with optional subelements
#todo - synchronize with value processing loop below
#- consider refactor to a common procedure for handling this issue of tracking updated typelist state for optional subelements in -multiple true clauses
tcl::dict::set argstate $leadername -type $newtypelist ;#(possible ?omitted-<type>? and ?defaulted-<type>? entries
#incorrect -don't update default -type info.
#tcl::dict::set argstate $leadername -type $newtypelist ;#(possible ?omitted-<type>? and ?defaulted-<type>? entries
}
if {[tcl::dict::get $argstate $leadername -multiple]} {
if {[dict exists $argument_clause_typestate $argname]} {
#lookup saved newtypelist (argument_clause_typelist) from can_assign_value result where some optionals were given type ?omitted-<tp>? or ?defaulted-<tp>?
#lookup saved newtypelist (argument_clause_typelist) from can_assign_value result where some optionals were given type ?omitted-<tp>? or ?defaulted-<tp>? or ?validated-<tp>?.
"Manage the hash table of autoexec commands cached in ::auto_execs."\
-help\
{see also ::punk::auto_exec::rehash}
#---------------------
@form -form {show_or_set}
@opts -min 0 -max 0
@values -min 0 -max -1
name -type string -multiple 1 -optional 1 -default {} -help\
"One or more autoexec command names to set.
If no names are provided, then all autoexec commands in the hash table will be shown."
#---------------------
@form -form {rehash}
@opts -min 1 -max 1
-r -type none -optional 0 -help\
"Clear autoexec commands from the hash table"
@values -min 0 -max 0
#---------------------
@form -form {test}
@opts
-t -type none -optional 0 -default "" -help\
"The name of the autoexec command name to display."
@values -min 1 -max -1
name -type string -multiple 1 -help\
"One or more autoexec command names to display information for.
If only a single name is provided, then the output will be the raw command string
associated with that autoexec command in the hash table.
If multiple names are provided, then the output will be a string containing each
name and its associated command string on a separate line."
#---------------------
@form -form {delete}
@opts
-d -type none -optional 0 -help\
"Delete specified autoexec commands from the hash table."
@values -min 1 -max -1
name -type string -multiple 1 -help\
"One or more autoexec command names to delete from the hash table."
#---------------------
#todo?
#-p <path> <name> (manually assign)
#-l (build a list of hash -p <path> <name> entries for all autoexec commands that can be used in a script to pre-populate the hash table without needing to call auto_execok for each command at runtime)
#---------------------
@form -form {help}
@opts -min 1 -max 1 -anyopts 1
--help -type none -optional 0 -help\
"Display usage information for this command."
@values -min 0 -max -1
ignored -type any -multiple 1 -optional 1 -help\
"Additional arguments that are ignored when --help is used"
}]
}
proc hash {args} {
set arg1 [lindex $args 0]
#select parsing form based on first argument
switch -- $arg1 {
-r {
set form rehash
}
-t {
set form test
}
-d {
set form delete
}
--help {
set form help
}
default {
#like bash in this context, we won't allow an option-like entry to be treated as an executable name
set argd [punk::args::parse $args -form $form withid ::punk::auto_exec::hash]
lassign [dict values $argd] _leaders opts values received
global auto_execs
switch -- $form {
rehash {
unset -nocomplain auto_execs
}
test {
#like bash - we'll provide only the path if there is a single name provided, but if there are multiple names we'll provide both the name and path for each.
return [list stdin [list from $oldmode to $newmode]]
}
}
proc enableRaw_powershell {{channel stdin}} {
#enableRaw_powershell is a fallback for when twapi is not present.
#It uses a persistent powershell process to set the console mode to raw, by writing commands to a named pipe that the powershell process is listening on.
#ENABLE_PROCESSED_INPUT 0x0001 ;#set to zero will allow ctrl-c to be reported as keyboard input rather than as a signal
#ENABLE_LINE_INPUT 0x0002
#ENABLE_ECHO_INPUT 0x0004
#ENABLE_WINDOW_INPUT 0x0008 (default off when a terminal created)
#ENABLE_WINDOW_INPUT 0x0008 (default off when a terminal created) enables reporting of windows resize events to console input buffer - no direct stty equiv for unix - sigwinch?
#ENABLE_MOUSE_INPUT 0x0010
#ENABLE_INSERT_MODE 0X0020
#ENABLE_QUICK_EDIT_MODE 0x0040
#ENABLE_VIRTUAL_TERMINAL_INPUT 0x0200 (default off when a terminal created) (512)
set h_in [twapi::get_console_handle stdin]
set oldmode_in [twapi::GetConsoleMode $h_in]
set newmode_in [expr {$oldmode_in | 8}]
#set newmode_in [expr {$oldmode_in | 0x208}]
#set h_in [twapi::get_console_handle stdin]
#set oldmode_in [twapi::GetConsoleMode $h_in]
##set newmode_in [expr {$oldmode_in | 8}]
twapi::SetConsoleMode $h_in $newmode_in
return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]]
##test
#set newmode_in [expr {$oldmode_in & ~8}]
#set newmode_in [expr {$newmode_in & ~0x200}]
#twapi::SetConsoleMode $h_in $newmode_in
#return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]]
return [list stdout [list from $oldmode_out to $newmode_out]]
if {[catch {punk::console::system::enableRaw_stty} errMsg]} {
puts stderr "enableRaw_stty failed: $errMsg"
}
#try also the 'best guess' implementation of enableRaw we installed above - which will be the twapi version if twapi is present, or the powershell version if not.
"Return a list of the server capabilities last received,
or a boolean indicating if a particular capability was
present."
@cmd -name punk::imap4::proto::has_capability\
-summary\
"List capabilities or test existence of a specific capability."\
-help\
"Returns a list of the server capabilities last received when called
with no argument.
Returns boolean indicating if a particular capability was
present when called with a capability argument. The capability argument is case-insensitive and should be specified in the same form as it would be expected to be received from"
set renamed ${routinens}::${routinetail}_[clock clicks] ;#clock clicks unlikely to collide when not directly consecutive such as: list [clock clicks] [clock clicks]
set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split seems to account for a large portion of the time taken to run this function.
set r [binary scan $lenfield su count_chars] ;# su is for unsigned short in little endian order
set string_value ""
if {[Header_Has_LinkFlag $contents "IsUnicode"]} {
#string is UTF-16LE encoded
#string is UTF-16LE encoded - we have this encoding available in tcl 9+ - but not in 8.6
set numbytes [expr {2 * $count_chars}]
set string_bytes [string range $contents $start+2 [expr {$start + 2 + $numbytes - 1}]]
#consider using tcl encoding convertfrom utf-16le instead of manually parsing the UTF-16LE bytes - this would be more robust and handle edge cases better (e.g. surrogate pairs, non-BMP characters, etc.)
set string_value [encoding convertfrom utf-16le $string_bytes]
#for {set i 0} {$i < [string length $string_bytes]} {
# set char_bytes [string range $string_bytes $i [expr {$i + 1}]]
# set r [binary scan $char_bytes su char] ;# s for unsigned short
# append string_value [format %c $char]
# incr i 1 ;# skip the next byte since it's part of the UTF-16LE encoding
#}
#use tcl encoding convertfrom utf-16le when we can instead of manually parsing the UTF-16LE bytes
#- this should be more robust and handle edge cases better (e.g. surrogate pairs, non-BMP characters, etc.)
if {[catch {set string_value [encoding convertfrom utf-16le $string_bytes]} err]} {
"Join blocks of text line by line but don't add padding on each line to enforce uniform width.
Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner.
This version is a thin wrapper around split and join for the common case of joining blocks without any options,
and is intended to avoid the overhead of argument parsing.
"
@values
blocks -type any -multiple 1
}
proc ::textblock::join_basic_raw {args} {
#do not use any argument parsing libs - this is intended as a thin wrapper around split and join for the common case of joining blocks without any options,
#and we want to avoid the overhead of argument parsing.
#no options. -*, -- are legimate blocks
set blocklists [lrepeat [llength $args] ""]
set blocklengths [lrepeat [expr {[llength $args]+1}] 0] ;#add 1 to ensure never empty - used only for rowcount max calc
