From d97971b04549944a43916de72e43e2879846bfe2 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Sat, 28 Mar 2026 03:32:45 +1100 Subject: [PATCH] punk::winlnk,punk::du,punk::auto_exec,punk::args,punk::nav::fs + tests,inspect,tstr,gohome & ~ & newdir & newns, documentation --- src/bootsupport/modules/commandstack-0.4.tm | 9 +- src/bootsupport/modules/punk-0.1.tm | 372 +++++++++--------- .../modules/punk/aliascore-0.1.0.tm | 6 +- src/bootsupport/modules/punk/args-0.2.1.tm | 232 +++++++++-- .../modules/punk/auto_exec-0.1.0.tm | 161 +++++--- src/bootsupport/modules/punk/config-0.1.tm | 17 +- src/bootsupport/modules/punk/du-0.1.0.tm | 158 +++++--- .../modules/punk/mix/util-0.1.0.tm | 9 +- src/bootsupport/modules/punk/nav/fs-0.1.0.tm | 281 +++++++++++-- src/bootsupport/modules/punk/nav/ns-0.1.0.tm | 92 ++++- src/bootsupport/modules/punk/ns-0.1.0.tm | 4 +- src/bootsupport/modules/punk/winlnk-0.1.1.tm | 83 ++-- src/modules/punk-0.1.tm | 372 +++++++++--------- src/modules/punk/aliascore-999999.0a1.0.tm | 6 +- src/modules/punk/args-999999.0a1.0.tm | 232 +++++++++-- src/modules/punk/auto_exec-999999.0a1.0.tm | 161 +++++--- src/modules/punk/config-0.1.tm | 17 +- src/modules/punk/du-999999.0a1.0.tm | 158 +++++--- src/modules/punk/mix/util-999999.0a1.0.tm | 9 +- src/modules/punk/nav/fs-999999.0a1.0.tm | 281 +++++++++++-- src/modules/punk/nav/ns-999999.0a1.0.tm | 92 ++++- src/modules/punk/netbox-999999.0a1.0.tm | 34 +- src/modules/punk/ns-999999.0a1.0.tm | 4 +- src/modules/punk/winlnk-999999.0a1.0.tm | 87 ++-- .../args-0.1.5_testsuites/args/choices.test | 29 +- .../bootsupport/modules/commandstack-0.4.tm | 9 +- .../src/bootsupport/modules/punk-0.1.tm | 372 +++++++++--------- .../modules/punk/aliascore-0.1.0.tm | 6 +- .../bootsupport/modules/punk/args-0.2.1.tm | 232 +++++++++-- .../modules/punk/auto_exec-0.1.0.tm | 161 +++++--- .../bootsupport/modules/punk/config-0.1.tm | 17 +- .../src/bootsupport/modules/punk/du-0.1.0.tm | 158 +++++--- .../modules/punk/mix/util-0.1.0.tm | 9 +- .../bootsupport/modules/punk/nav/fs-0.1.0.tm | 281 +++++++++++-- .../bootsupport/modules/punk/nav/ns-0.1.0.tm | 92 ++++- .../src/bootsupport/modules/punk/ns-0.1.0.tm | 4 +- .../bootsupport/modules/punk/winlnk-0.1.1.tm | 83 ++-- .../bootsupport/modules/commandstack-0.4.tm | 9 +- .../src/bootsupport/modules/punk-0.1.tm | 372 +++++++++--------- .../modules/punk/aliascore-0.1.0.tm | 6 +- .../bootsupport/modules/punk/args-0.2.1.tm | 232 +++++++++-- .../modules/punk/auto_exec-0.1.0.tm | 161 +++++--- .../bootsupport/modules/punk/config-0.1.tm | 17 +- .../src/bootsupport/modules/punk/du-0.1.0.tm | 158 +++++--- .../modules/punk/mix/util-0.1.0.tm | 9 +- .../bootsupport/modules/punk/nav/fs-0.1.0.tm | 281 +++++++++++-- .../bootsupport/modules/punk/nav/ns-0.1.0.tm | 92 ++++- .../src/bootsupport/modules/punk/ns-0.1.0.tm | 4 +- .../bootsupport/modules/punk/winlnk-0.1.1.tm | 83 ++-- .../modules/commandstack-0.4.tm | 9 +- src/vfs/_vfscommon.vfs/modules/punk-0.1.tm | 372 +++++++++--------- .../modules/punk/aliascore-0.1.0.tm | 6 +- .../_vfscommon.vfs/modules/punk/args-0.2.1.tm | 232 +++++++++-- .../modules/punk/auto_exec-0.1.0.tm | 161 +++++--- .../_vfscommon.vfs/modules/punk/config-0.1.tm | 17 +- .../_vfscommon.vfs/modules/punk/du-0.1.0.tm | 158 +++++--- .../modules/punk/mix/util-0.1.0.tm | 9 +- .../modules/punk/nav/fs-0.1.0.tm | 281 +++++++++++-- .../modules/punk/nav/ns-0.1.0.tm | 92 ++++- .../modules/punk/netbox-0.1.1.tm | 34 +- .../_vfscommon.vfs/modules/punk/ns-0.1.0.tm | 4 +- .../modules/punk/winlnk-0.1.1.tm | 83 ++-- .../modules/test/punk/args-0.1.5.tm | Bin 19045 -> 19189 bytes 63 files changed, 5058 insertions(+), 2154 deletions(-) diff --git a/src/bootsupport/modules/commandstack-0.4.tm b/src/bootsupport/modules/commandstack-0.4.tm index 19c21289..165bd16a 100644 --- a/src/bootsupport/modules/commandstack-0.4.tm +++ b/src/bootsupport/modules/commandstack-0.4.tm @@ -167,6 +167,12 @@ namespace eval commandstack { lassign $arglist command procargs procbody set command [uplevel 1 [list namespace which $command]] + if {$command eq ""} { + #review + puts stderr "commandstack::rename_command no rename performed for command '$command' by '$renamer'. command '$command' not found in calling context. Ensure command name is fully qualified or that command exists." + #add something to stack? + return [dict create implementation ""] + } set mungedcommand [string map {:: _ns_} $command] set mungedrenamer [string map {:: _ns_} $renamer] variable all_stacks @@ -284,7 +290,8 @@ namespace eval commandstack { ] if {![dict get $nextinfo do_rename]} { #review - puts stderr "no rename performed" + puts stderr "commandstack::rename_command no rename performed for command '$command' by '$renamer'" + #add something to stack? return [dict create implementation ""] } catch {rename ::commandstack::temp::testproc ""} diff --git a/src/bootsupport/modules/punk-0.1.tm b/src/bootsupport/modules/punk-0.1.tm index 5a7824f0..ebfb673f 100644 --- a/src/bootsupport/modules/punk-0.1.tm +++ b/src/bootsupport/modules/punk-0.1.tm @@ -35,29 +35,13 @@ namespace eval punk { " } - proc rehash {{refresh 0}} { - global auto_execs - if {!$refresh} { - unset -nocomplain auto_execs - } else { - set names [array names auto_execs] - unset -nocomplain auto_execs - foreach nm $names { - auto_execok_windows $nm - } - } - return - } proc ::punk::auto_execok_original name [info body ::auto_execok] variable better_autoexec - #set better_autoexec 0 ;#use this var via better_autoexec only - #proc ::punk::auto_execok_windows name { - # ::punk::auto_execok_original $name - #} + #use this var via better_autoexec only set better_autoexec 1 proc ::punk::auto_execok_windows name { ::punk::auto_execok_better $name @@ -166,14 +150,14 @@ namespace eval punk { proc ::punk::auto_execok_windows name { ::punk::auto_execok_better $name } - punk::rehash + punk::auto_exec::rehash } elseif {!$onoff && ($onoff != $better_autoexec)} { puts "Turning off better_autoexec - search extension then PATH" set better_autoexec 0 proc ::punk::auto_execok_windows name { ::punk::auto_execok_original $name } - punk::rehash + punk::auto_exec::rehash } else { puts "no change" } @@ -182,6 +166,16 @@ namespace eval punk { proc auto_execok_better name { + #review - we have a gneral problem of auto_exec caching negative results for relative paths. + #A failed resolution of a relative path should not generate an entry in ::auto_execs. + #This happens in plain tclsh - so we need to determine where in Tcl this happens and fix it there. + #Simply returning an empty string here will still result in a negative cache entry. + #we want to cache negative results for absolute paths or plain filenames with no file-separator. + #e.g ./doesntexist.exe should not be cached as not found, but should be re-resolved every time. (cwd dependent) + #e.g doesntexist.exe should be cached as not found, because it will always be not found until it appears in the PATH. + #i.e it is required to prefix with ./ to exec a file in the current directory. (similar to unix shells) + + global auto_execs env tcl_platform #for now at least, auto_execok_better is windows-specific. package require punk::auto_exec @@ -213,7 +207,16 @@ namespace eval punk { } if {[llength [file split $name]] != 1} { + #----------------------------------------------------- #has a path component - could be relative or absolute. + #----------------------------------------------------- + if {[file pathtype $name] eq "relative"} { + #don't cache negative result for any relative paths - as they may become valid if the file appears in the relative location, or if the user changes directory and the same relative path points to a different file. + #our only way to do this is by cooperating with the unknown handler. + set auto_execs($name) "for_unknown_handler by punk::auto_exec relative_path - file existence should be re-checked at call time" + return $auto_execs($name) + } + if {[string tolower [file extension $name]] eq ".lnk"} { #special case .lnk #todo - consider working directory or other properties of link before launching? @@ -246,11 +249,11 @@ namespace eval punk { set associnfo [punk::auto_exec::shell_open_command $test_ext] set valuetype [dict get $associnfo type] set assoc [dict get $associnfo value] - set ftype [dict get $associnfo filetype] + set windows_file_type [dict get $associnfo filetype] if {$assoc eq ""} { return [set auto_execs($name) [list $file]] } else { - if {[file pathtype $target] eq "relative" && $ftype eq "InternetShortcut"} { + if {[file pathtype $target] eq "relative" && $windows_file_type eq "InternetShortcut"} { #special case InternetShortcut - cannot accept relative path - so we can't cache it in auto_execs if we used a relative path to launch #if we return an empty string - the auto_exec will fail to launch this every time. #The best we can do is return a token for the 'unknown' process to detect and re-resolve the path every time. @@ -260,7 +263,7 @@ namespace eval punk { #e.g ::auto_execs(./link.url) = some.exe c:/desktop/link.url #this would be wrong if the user changed directory and tried to run ./link.url again on a different file with the same name # - as the cached path would no longer be correct. - return [set auto_execs($name) "(resolve_in_unknown_handler) punk::auto_exec absolute_path required"] + return [set auto_execs($name) "for_unknown_handler by punk::auto_exec absolute_path required"] } puts stderr "auto_execok_better: (review required) assoc $assoc for file $file ext $test_ext" set run [punk::auto_exec::shell_command_as_tcl_list -type $valuetype $assoc $file] ;# -workingdir [pwd] vs path of script? @@ -269,6 +272,8 @@ namespace eval punk { } } } + #cache negative result for absolute paths - as they will always point to the same location, so if they don't exist now, they won't exist later. + set auto_execs($name) "" return "" } @@ -559,7 +564,7 @@ if {![llength [info commands ::ansistring]]} { package require punk::repl::codethread package require punk::config #package require textblock -package require punk::console ;#requires Thread +catch {package require punk::console} ;#requires Thread - will not work in safe interps. package require punk::ns package require punk::winpath ;# for windows paths - but has functions that can be called on unix systems package require punk::repo @@ -5396,27 +5401,54 @@ namespace eval punk { } else { set repl_runid [punk::get_repl_runid] #set ::punk::last_run_display [list] - if {$new eq "(resolve_in_unknown_handler) punk::auto_exec absolute_path required"} { - #re-resolve. - puts "(unknown-handler): auto_execok for $name requires absolute path. Re-resolving $name with absolute path." + set resolved $new + if {[string match "for_unknown_handler *" $new]} { set ext [file extension $name] - set associnfo [punk::auto_exec::shell_open_command $ext] - set valuetype [dict get $associnfo type] - set assoc [dict get $associnfo value] - set ftype [dict get $associnfo filetype] - set fullpath [file normalize $name] - #at least for .url files - long paths (paths with multiple spaces?) can fail to run. Using the short path seems to fix this. - #This seems hacky but anyway.. - set attributes [file attributes $fullpath] - if {[dict exists $attributes -shortname]} { - set fullpath [dict get $attributes -shortname] + if {[string tolower $ext] eq ".lnk"} { + #for .lnk files we can often resolve the target path without needing to execute the shell open command + #- which is desirable because it allows us to avoid the absolute path requirement for unknown-handler auto_execok commands, + #which is desirable because it allows us to support relative paths and paths with environment variables in them + #(e.g for .lnk files that point to executables with environment variables in the path) + set targetinfo [punk::winlnk::resolve $name] + if {[dict exists $targetinfo link_roottarget]} { + set resolved [dict get $targetinfo link_roottarget] + #arguments? + } else { + puts "(unknown-handler): failed to resolve .lnk target for $name. Falling back to shell open command resolution, which may fail if absolute path is required." + } + } else { + #re-resolve. + set associnfo [punk::auto_exec::shell_open_command $ext] + set registry_valuetype [dict get $associnfo type] ;#sz vs expand_sz + set command_spec [dict get $associnfo value] + set windows_file_type [dict get $associnfo filetype] + if {[string match "*absolute_path required" $new]} { + puts "(unknown-handler): auto_execok for $name requires absolute path. Re-resolving $name with absolute path." + set fullpath [file normalize $name] + #at least for .url files - long paths (paths with multiple spaces?) can fail to run. Using the short path seems to fix this. + #This seems hacky but anyway.. + set attributes [file attributes $fullpath] + if {[dict exists $attributes -shortname]} { + set fullpath [dict get $attributes -shortname] + } + set resolved [punk::auto_exec::shell_command_as_tcl_list -type $registry_valuetype $command_spec $fullpath] + } else { + #todo + set newnorm [file normalize $name] + puts stderr "(unknown-handler): re-resolving $name with auto_execok $newnorm" + set resolved [auto_execok $newnorm] + } } - set new [punk::auto_exec::shell_command_as_tcl_list -type $valuetype $assoc $fullpath] } - + if {$resolved eq ""} { + #resolved may be emptyif auto_execok returns an empty string. + dict set ::tcl::UnknownOptions -code error + set ::tcl::UnknownResult "unresolved path '$name'" + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } set redir ">&@stdout <@stdin" - uplevel 1 [list ::catch [concat exec $redir $new [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions] + uplevel 1 [list ::catch [concat exec $redir $resolved [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions] #we can't detect stdout/stderr output from the exec #for now emit an extra \n on stderr #todo - there is probably no way around this but to somehow exec in the context of a completely separate console @@ -5502,8 +5534,7 @@ namespace eval punk { set default_cmd_search 0 if {$default_cmd_search} { if {[llength $cmds] == 1} { - uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] \ - ::tcl::UnknownResult ::tcl::UnknownOptions] + uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] ::tcl::UnknownResult ::tcl::UnknownOptions] dict incr ::tcl::UnknownOptions -level return -options $::tcl::UnknownOptions $::tcl::UnknownResult } @@ -6779,46 +6810,6 @@ namespace eval punk { - #tilde - #These aliases work fine for interactive use - but the result is always a string int-rep - #interp alias {} ~ {} file join $::env(HOME) ;#HOME must be capitalized to work cross platform (lowercase home works on windows - but probably not elsewhere) - #interp alias {} ~ {} apply {args {file join $::env(HOME) $args}} - namespace eval argdoc { - punk::args::define { - @id -id ::punk::~ - @cmd -name "punk::~"\ - -summary\ - "Return home directory"\ - -help\ - "Return the home directory path. With additional arguments, - return the path obtained by joining the home directory with - the supplied arguments. - - usage e.g - cd [~] - (change to home directory) - .// [~] .config - (change to .config directory within home directory - and list contents.) - " - @opts - @values -min 0 -max -1 - arg -type any -optional 1 -multiple 1 - } - } - proc ~ {args} { - set hdir [punk::valcopy $::env(HOME)] - file pathtype $hdir - set d $hdir - #use the file join 2-arg optimisation to avoid losing path-rep - probably doesn't give any advantage on all Tcl versions - #review - for what versions does/did the 2-arg version of file join not just return a string? - foreach a $args { - set d [file join $d $a] - } - file pathtype $d - return [punk::valcopy $d] - } - interp alias {} ~ {} punk::~ #maint - punk::args has similar @@ -7735,12 +7726,20 @@ namespace eval punk { -limit -type int -default 20 -help\ "When multiple values are passed to inspect - limit the number of elements displayed in -channel output. + When truncation has occured an elipsis indication (...) will be appended. e.g - .= lseq 20 to 50 by 3 |> .=>* inspect -limit 4 -- |> .=>* tcl::mathop::+ - (11) 20 23 26 29... + ${[punk::args::helpers::example { - - 385 + .= lseq 20 to 50 by 3 |> .=>* inspect -limit 4 -- |> .=>* tcl::mathop::+ + (11) 20 23 26 29... + + - 385 + + }]} + + If the current pipeline data is not a list, the limit is applied to the + number of lines in the pipeline value. For no limit - use -limit -1 " @@ -7881,11 +7880,11 @@ namespace eval punk { } if {$showcount} { set displaycount "[a purple bold]($count)[a] " - if {$showcount} { - set countspace [expr {[string length $count] + 3}] ;#lhs margin size of count number plus brackets and one space - set margin [string repeat " " $countspace] - set displayval [string map [list \r "" \n "\n$margin"] $displayval] - } + #if {$showcount} { + # set countspace [expr {[string length $count] + 3}] ;#lhs margin size of count number plus brackets and one space + # set margin [string repeat " " $countspace] + # set displayval [string map [list \r "" \n "\n$margin"] $displayval] + #} } else { set displaycount "" } @@ -7934,10 +7933,13 @@ namespace eval punk { } if {![string length $more]} { - puts $channel "$displaycount$label$displayval[a]" + #puts $channel "$displaycount$label$displayval[a]" + set chunk [textblock::join -- $displaycount$label " " $displayval[a]] } else { - puts $channel "$displaycount$label$displayval[a yellow bold]$more[a]" + #puts $channel "$displaycount$label$displayval[a yellow bold]$more[a]" + set chunk [textblock::join -- $displaycount$label " " "$displayval[a yellow bold]$more[a]"] } + puts $channel $chunk return $val } @@ -8024,7 +8026,7 @@ namespace eval punk { lappend cmdinfo [list ./ "?${I}glob${NI}?" "view/change dir, list dirs."] lappend cmdinfo [list ../ "?${I}path${NI}" "go up one dir, then to path if given"] lappend cmdinfo [list .// "?${I}glob${NI}?" "view/change dir, list dirs and files"] - lappend cmdinfo [list ./new "${I}subdir${NI}..." "make new dir or dirs and show status"] + lappend cmdinfo [list newdir "${I}subdir${NI}..." "make new dir or dirs and show status"] lappend cmdinfo [list fcat "${I}file ?file?...${NI}" "cat file(s)"] set t [textblock::class::table new -minwidth 80 -show_seps 0] foreach row $cmdinfo { @@ -8046,9 +8048,9 @@ namespace eval punk { set title "[a+ brightgreen] Namespace navigation: " set cmdinfo [list] lappend cmdinfo [list n/ "?${I}ns${NI}|${I}glob${NI}?" "view/change namespace\n (accepts ns path globs e.g **::*get* to match\n commands at any level )"] - lappend cmdinfo [list n// "?${I}ns${NI}|${I}glob${NI}?" "view/change namespace (with command listing)"] - lappend cmdinfo [list "nn/" "" "go up one namespace"] - lappend cmdinfo [list "n/new" "${I}ns${NI}" "make child namespace and switch to it"] + lappend cmdinfo [list n// "?${I}ns${NI}|${I}glob${NI}?" "view/change namespace (with command listing)"] + lappend cmdinfo [list "nn/" "" "go up one namespace"] + lappend cmdinfo [list "newns" "${I}ns${NI}" "make child namespace and switch to it"] set t [textblock::class::table new -minwidth 80 -show_seps 0] foreach row $cmdinfo { $t add_row $row @@ -8236,104 +8238,110 @@ namespace eval punk { lappend chunks [list stdout $text] } console - term - terminal { - set indent [string repeat " " [string length "WARNING: "]] - lappend cstring_tests [dict create\ - type "PM "\ - msg "UN"\ - f7 punk::ansi::controlstring_PM\ - f7prefix "7bit ESC ^ secret "\ - f7suffix "safe"\ - f8 punk::ansi::controlstring_PM8\ - f8prefix "8bit \\x9e secret "\ - f8suffix "safe"\ - ] - lappend cstring_tests [dict create\ - type SOS\ - msg "NOT"\ - f7 punk::ansi::controlstring_SOS\ - f7prefix "7bit ESC X string "\ - f7suffix " hidden"\ - f8 punk::ansi::controlstring_SOS8\ - f8prefix "8bit \\x98 string "\ - f8suffix " hidden"\ - ] - lappend cstring_tests [dict create\ - type APC\ - msg "NOT"\ - f7 punk::ansi::controlstring_APC\ - f7prefix "7bit ESC _ APPLICATION PROGRAM COMMAND "\ - f7suffix " hidden"\ - f8 punk::ansi::controlstring_APC8\ - f8prefix "8bit \\x9f APPLICATION PROGRAM COMMAND "\ - f8suffix " hidden"\ - ] + if {[catch {package require punk::console} result]} { + set text "Unable to load punk::console package - cannot test\n$result" + lappend chunks [list stdout $text] + } else { - foreach test $cstring_tests { - set m [[dict get $test f7] [dict get $test msg]] - set hidden_width_m [punk::console::test_char_width $m] - set m8 [[dict get $test f8] [dict get $test msg]] - set hidden_width_m8 [punk::console::test_char_width $m8] - if {$hidden_width_m != 0 || $hidden_width_m8 != 0} { - if {$hidden_width_m == 0} { - set d "[a+ green bold][dict get $test f7prefix][a red]${m}[a][a+ green bold][dict get $test f7suffix][a]" - } else { - set d "[a+ yellow bold][dict get $test f7prefix][a red]$m[a][a+ yellow bold][dict get $test f7suffix][a]" - } - if {$hidden_width_m8 == 0} { - set d8 "[a+ green ][dict get $test f8prefix][a red]$m8[a][a+ green][dict get $test f8suffix][a]" - } else { - set d8 "[a+ yellow bold][dict get $test f8prefix][a red]$m8[a][a+ yellow bold][dict get $test f8suffix][a]" + set indent [string repeat " " [string length "WARNING: "]] + lappend cstring_tests [dict create\ + type "PM "\ + msg "UN"\ + f7 punk::ansi::controlstring_PM\ + f7prefix "7bit ESC ^ secret "\ + f7suffix "safe"\ + f8 punk::ansi::controlstring_PM8\ + f8prefix "8bit \\x9e secret "\ + f8suffix "safe"\ + ] + lappend cstring_tests [dict create\ + type SOS\ + msg "NOT"\ + f7 punk::ansi::controlstring_SOS\ + f7prefix "7bit ESC X string "\ + f7suffix " hidden"\ + f8 punk::ansi::controlstring_SOS8\ + f8prefix "8bit \\x98 string "\ + f8suffix " hidden"\ + ] + lappend cstring_tests [dict create\ + type APC\ + msg "NOT"\ + f7 punk::ansi::controlstring_APC\ + f7prefix "7bit ESC _ APPLICATION PROGRAM COMMAND "\ + f7suffix " hidden"\ + f8 punk::ansi::controlstring_APC8\ + f8prefix "8bit \\x9f APPLICATION PROGRAM COMMAND "\ + f8suffix " hidden"\ + ] + + foreach test $cstring_tests { + set m [[dict get $test f7] [dict get $test msg]] + set hidden_width_m [punk::console::test_char_width $m] + set m8 [[dict get $test f8] [dict get $test msg]] + set hidden_width_m8 [punk::console::test_char_width $m8] + if {$hidden_width_m != 0 || $hidden_width_m8 != 0} { + if {$hidden_width_m == 0} { + set d "[a+ green bold][dict get $test f7prefix][a red]${m}[a][a+ green bold][dict get $test f7suffix][a]" + } else { + set d "[a+ yellow bold][dict get $test f7prefix][a red]$m[a][a+ yellow bold][dict get $test f7suffix][a]" + } + if {$hidden_width_m8 == 0} { + set d8 "[a+ green ][dict get $test f8prefix][a red]$m8[a][a+ green][dict get $test f8suffix][a]" + } else { + set d8 "[a+ yellow bold][dict get $test f8prefix][a red]$m8[a][a+ yellow bold][dict get $test f8suffix][a]" + } + append warningblock \n "WARNING: terminal doesn't hide all [dict get $test type] control strings: $d $d8" } - append warningblock \n "WARNING: terminal doesn't hide all [dict get $test type] control strings: $d $d8" } - } - if {![catch {punk::console::check::has_bug_legacysymbolwidth} result]} { - if {$result} { - append warningblock \n "WARNING: terminal has legacysymbolwidth bug - screen position for symbol reports 2 wide but displays 1 wide." - append warningblock \n $indent "Layout using 'legacy symbols for computing' affected." - append warningblock \n $indent "(e.g textblock frametype block2 unsupported)" - append warningblock \n $indent "This can cause extreme layout deformation when ANSI is present" - append warningblock \n $indent "In some cases unwanted spacing effects occur at a distance from the characters causing it" + if {![catch {punk::console::check::has_bug_legacysymbolwidth} result]} { + if {$result} { + append warningblock \n "WARNING: terminal has legacysymbolwidth bug - screen position for symbol reports 2 wide but displays 1 wide." + append warningblock \n $indent "Layout using 'legacy symbols for computing' affected." + append warningblock \n $indent "(e.g textblock frametype block2 unsupported)" + append warningblock \n $indent "This can cause extreme layout deformation when ANSI is present" + append warningblock \n $indent "In some cases unwanted spacing effects occur at a distance from the characters causing it" + } + } else { + append warningblock \n "WARNING: terminal unable to check for legacysymbolwidth bug. err:$result" } - } else { - append warningblock \n "WARNING: terminal unable to check for legacysymbolwidth bug. err:$result" - } - if {![catch {punk::console::check::has_bug_zwsp} result]} { - if {$result} { - append warningblock \n "WARNING: terminal has zero width space (\\u200b) bug - cursor position incremented when it shouldn't be." - append warningblock \n $indent "The zwsp may or may not be displayed. zwsp contributes to line length and wrapping point" + if {![catch {punk::console::check::has_bug_zwsp} result]} { + if {$result} { + append warningblock \n "WARNING: terminal has zero width space (\\u200b) bug - cursor position incremented when it shouldn't be." + append warningblock \n $indent "The zwsp may or may not be displayed. zwsp contributes to line length and wrapping point" + } + } else { + append warningblock \n "WARNING: terminal unable to check for zwsp bug. err:$result" } - } else { - append warningblock \n "WARNING: terminal unable to check for zwsp bug. err:$result" - } - set grapheme_support [punk::console::grapheme_cluster_support] - #mode, 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) - if {![dict size $grapheme_support] || [dict get $grapheme_support mode] eq "unsupported" } { - append warningblock \n "WARNING: terminal either doesn't support grapheme clusters, or doesn't report so via decmode 2027 query." - if {[dict size $grapheme_support] && [dict get $grapheme_support available]} { - append warningblock \n $indent "(but punk::console::grapheme_cluster_support has determined it is probably available)" - } - } else { - if {![dict get $grapheme_support available]} { - switch -- [dict get $grapheme_support mode] { - "unset" { - append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is off." - } - "permanently_unset" { - append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is permanently off." - } - "BAD_RESPONSE" { - append warningblock \n "WARNING: terminal doesn't seem to recognize decmode 2027 query. No grapheme cluster support." + set grapheme_support [punk::console::grapheme_cluster_support] + #mode, 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) + if {![dict size $grapheme_support] || [dict get $grapheme_support mode] eq "unsupported" } { + append warningblock \n "WARNING: terminal either doesn't support grapheme clusters, or doesn't report so via decmode 2027 query." + if {[dict size $grapheme_support] && [dict get $grapheme_support available]} { + append warningblock \n $indent "(but punk::console::grapheme_cluster_support has determined it is probably available)" + } + } else { + if {![dict get $grapheme_support available]} { + switch -- [dict get $grapheme_support mode] { + "unset" { + append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is off." + } + "permanently_unset" { + append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is permanently off." + } + "BAD_RESPONSE" { + append warningblock \n "WARNING: terminal doesn't seem to recognize decmode 2027 query. No grapheme cluster support." + } } } } - } - if {![string length $warningblock]} { - set text "No terminal warnings\n" - lappend chunks [list stdout $text] + if {![string length $warningblock]} { + set text "No terminal warnings\n" + lappend chunks [list stdout $text] + } } } topics - help { diff --git a/src/bootsupport/modules/punk/aliascore-0.1.0.tm b/src/bootsupport/modules/punk/aliascore-0.1.0.tm index fb5adce3..8450b2c8 100644 --- a/src/bootsupport/modules/punk/aliascore-0.1.0.tm +++ b/src/bootsupport/modules/punk/aliascore-0.1.0.tm @@ -108,7 +108,7 @@ tcl::namespace::eval punk::aliascore { # the aliascore::init will temporarily extend the exports list to do the import, and then reset the exports to how they were. set aliases [tcl::dict::create\ val ::punk::pipe::val\ - tstr ::punk::lib::tstr\ + tstr ::punk::args::lib::tstr\ list_as_lines ::punk::lib::list_as_lines\ lines_as_list ::punk::lib::lines_as_list\ linelist ::punk::lib::linelist\ @@ -116,7 +116,7 @@ tcl::namespace::eval punk::aliascore { pdict ::punk::lib::pdict\ plist {::punk::lib::pdict -roottype list}\ showlist {::punk::lib::showdict -roottype list}\ - rehash ::punk::rehash\ + rehash ::punk::auto_exec::rehash\ showdict ::punk::lib::showdict\ ansistrip ::punk::ansi::ansistrip\ stripansi ::punk::ansi::ansistrip\ @@ -228,7 +228,7 @@ tcl::namespace::eval punk::aliascore { } } if {!$opt_force && [llength $conflicts]} { - error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts" + error "punk::aliascore::init declined to create any aliases or imports because conflicts found. Use -force == 1 conflicts:\n [join $conflicts "\n "]" } set failed [list] diff --git a/src/bootsupport/modules/punk/args-0.2.1.tm b/src/bootsupport/modules/punk/args-0.2.1.tm index 5abc839d..cb6f796b 100644 --- a/src/bootsupport/modules/punk/args-0.2.1.tm +++ b/src/bootsupport/modules/punk/args-0.2.1.tm @@ -273,21 +273,68 @@ tcl::namespace::eval ::punk::args {} tcl::namespace::eval ::punk::args::helpers { variable PUNKARGS namespace export * - #proc B {} {return \x1b\[1m} ;#a+ bold - #proc N {} {return \x1b\[22m} ;#a+ normal - #proc I {} {return \x1b\[3m} ;#a+ italic - #proc NI {} {return \x1b\[23m} ;#a+ noitalic - proc I {} {punk::ansi::a+ italic} - proc B {} {punk::ansi::a+ bold} - proc N {} {punk::ansi::a+ normal} - proc NI {} {punk::ansi::a+ italic} + proc B {} {return \x1b\[1m} ;#a+ bold + proc N {} {return \x1b\[22m} ;#a+ normal + proc I {} {return \x1b\[3m} ;#a+ italic + proc NI {} {return \x1b\[23m} ;#a+ noitalic + #proc I {} {punk::ansi::a+ italic} + #proc B {} {punk::ansi::a+ bold} + #proc N {} {punk::ansi::a+ normal} + #proc NI {} {punk::ansi::a+ italic} lappend PUNKARGS [list { @id -id ::punk::args::helpers::example @cmd -name punk::args::helpers::example\ -summary\ {Display formatting for argdoc example text}\ -help\ - {Wrap } + {Wrap a block of text (e.g tcl code) in a box with optional syntax highlighting and title. + The text is processed with punk::lib::tstr to allow for command substitution and basic formatting, + but without any further dedenting (i.e it's assumed the text is already dedented appropriately + based on context). + The example function is intended for use in punk::args::define scripts to format example text in + the generated documentation, but it can be used in other contexts too. + + The box is a plain grey background with a lighter grey top and bottom border. + There are no side borders so the text can be copied without extra characters getting in the way, + These top and bottom bars are implemented using unicode block characters so the bars are still + visible when ANSI is stripped. + + ${[punk::args::helpers::example -title "[a+ term-yellow Term-blue] Example 1 [a]" { + #A sample of an example block of text with a garish title and some basic tcl syntax highlighting. + + proc test {args} { + puts "[a+ red]hello world[a]" + } + + }]} + + This was generated with code like the following in the punk::args::define script: + + ${[punk::args::helpers::example -syntax none -tstr 1 { + + ${[example -title "[a+ term-yellow Term-blue] Example 1 [a]" { + #A sample of an example block of text with a garish title and some basic tcl syntax highlighting. + + proc test {args} { + puts "[a+ red]hello world[a]" + } + + }]} + + }]} + + Here we eat our own dog food by nesting the example text within an ${[B]}example${[N]} call with -tstr 0 + to prevent the tstr processing of the text, and -syntax none to prevent the syntax highlighting. + This allows us to show the actual code used to generate ${[a+ term-yellow Term-blue]} Example 1 ${[a+ defaultbg][a]} above without having to use any + escaping backslashes etc that may show in the output. + + Note the slight indent of 2 characters on the left of the text in the example block. + This is intentional to show that the text is indented within the box, and as it's reasonably appealing + visually, explains why the -padright option defaults to padding with 2 chars on the right of the text. + + see also ${[B]}punk::args::lib::tstr${[N]} + + } @opts -padright -type integer -default 2 -help\ {Number of padding spaces to add on RHS of text block} @@ -295,9 +342,24 @@ tcl::namespace::eval ::punk::args::helpers { tcl\ " Very basic tcl syntax highlighting of braces,square brackets and comments." - -title -type string -default "" + } + -title -type string -default "" -help\ + {Optional title to display in the top border of the box. + The title is overlaid on the top bar which consists of lower-half block characters. + These block characters are set with foreground black and background silver, so the lower portion + of the bar appears silver. When the title is overlaid on top of this it gets the same colouring + so that the result is black text on siver background, but full height for the width of the title text. + + The title colour can be set to something other than the default black on silver by including ANSI in + the title text, but the bar on either side will still be silver. + e.g -title "[a+ term-yellow Term-blue]yellow on blue title[a]" + } + -tstr -type boolean -default 1 -help\ + {By setting this to false, we can disable tstr processing of the text. This means that the text will be + treated as a literal string and any tstr variable or command substitution will not be processed. + This can be useful if you want to include text that contains tstr formatting characters or commands + without them being interpreted.} -titlealign -type string -choices {left centre right} - } text -type string }] proc example {args} { @@ -317,10 +379,11 @@ tcl::namespace::eval ::punk::args::helpers { -syntax tcl\ -title ""\ -titlealign left\ + -tstr 1\ ] dict for {o v} $optlist { switch -- $o { - -padright - -syntax - -title - -titlealign {} + -padright - -syntax - -title - -titlealign - -notstr {} default { punk::args::parse $args withid ::punk::args::helpers::example return @@ -332,6 +395,7 @@ tcl::namespace::eval ::punk::args::helpers { set opt_syntax [dict get $opts -syntax] set opt_title [dict get $opts -title] set opt_titlealign [dict get $opts -titlealign] + set opt_tstr [dict get $opts -tstr] if {[string index $str 0] eq "\n"} { set str [string range $str 1 end] @@ -341,7 +405,10 @@ tcl::namespace::eval ::punk::args::helpers { } #example is intended to run from a source doc that has already been dedented appropriately based on context # - we don't want to further undent, hence -undent 0 - set str [uplevel 1 [list punk::lib::tstr -undent 0 -return string -eval 1 -allowcommands $str]] + if {$opt_tstr} { + #this is the default + set str [uplevel 1 [list punk::lib::tstr -undent 0 -return string -eval 1 -allowcommands $str]] + } #puts stderr ------------------- #puts $str #puts stderr ------------------- @@ -752,6 +819,10 @@ tcl::namespace::eval punk::args { argument name - only applies to final leader OR final value) (for options/flags this allows the opt-val pair or solo flag to appear multiple times - not necessarily contiguously) + -multipleunique (only valid if -multiple is true) + If true, when multiple values are stored against the same argument + name due to -multiple being true, the values must be unique. + If false, the same value can be stored multiple times. -choices {} A list of allowable values for an argument. The -default value doesn't have to be in the list. @@ -809,6 +880,24 @@ tcl::namespace::eval punk::args { If allows more than one choice the value is a list consisting of items in the choices made available through entries in -choices/-choicegroups. + -choicemultipleunique (default 0) + If choicemultiple is set to allow more than one choice, this + option specifies whether the choices must be unique within the + value list. If true, the same choice can't be selected more than + once. If false, the same choice can be selected multiple times. + -choicemultipleuniqueset (default 0) + Only applies if -choicemultiple is true and -multiple is true. + If choicemultiple is set to allow more than one choice, and + -multiple is true, this option specifies whether the sets of + choices must be unique across multiple occurrences of the argument. + If true, the same set of choices can't be selected more than once + across multiple occurrences of the multi-choice argument. + If false, the same set of choices can be selected multiple times + across multiple occurrences of the argument. + Without this option being set true, if -multiple is true and + -multipleunique is true, then the same set of choices in a + different order would be considered unique, which may not be + desirable. -unindentedfields {} for fields with multi-line values, tell the resolver to treat them as unindented. ie do no indent/unindent processing of @@ -902,8 +991,11 @@ tcl::namespace::eval punk::args { -choiceprefix 1\ -choicerestricted 1\ -choicemultiple {1 1}\ + -choicemultipleunique 0\ + -choicemultipleuniqueset 0\ -unindentedfields {}\ -multiple 0\ + -multipleunique 0\ -regexprepass {}\ -validationtransform {}\ -ensembleparameter 0\ @@ -918,8 +1010,11 @@ tcl::namespace::eval punk::args { -choiceprefix 1\ -choicerestricted 1\ -choicemultiple {1 1}\ + -choicemultipleunique 0\ + -choicemultipleuniqueset 0\ -unindentedfields {}\ -multiple 0\ + -multipleunique 0\ -regexprepass {}\ -validationtransform {}\ -prefix 1\ @@ -938,8 +1033,11 @@ tcl::namespace::eval punk::args { -choiceprefix 1\ -choicerestricted 1\ -choicemultiple {1 1}\ + -choicemultipleunique 0\ + -choicemultipleuniqueset 0\ -unindentedfields {}\ -multiple 0\ + -multipleunique 0\ -regexprepass {}\ -validationtransform {}\ ] @@ -1718,7 +1816,8 @@ tcl::namespace::eval punk::args { } -unindentedfields - -minsize - -maxsize - - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - + -choices - -choicegroups - -choicemultiple - + -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted { #review - only apply to certain types? tcl::dict::set tmp_optspec_defaults $k $v @@ -1807,7 +1906,8 @@ tcl::namespace::eval punk::args { -allow_ansi - -validate_ansistripped - -strip_ansi - - -multiple - + -multiple - -multipleunique - + -choicemultipleunique - -choicemultipleuniqueset - -prefix { #check is bool if {![string is boolean -strict $v]} { @@ -1823,6 +1923,7 @@ tcl::namespace::eval punk::args { -unindentedfields\ -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple -prefix\ + -multipleunique -choicemultipleunique -choicemultipleuniqueset\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ } error "punk::args::resolve - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" @@ -1936,7 +2037,10 @@ tcl::namespace::eval punk::args { -allow_ansi - -validate_ansistripped - -strip_ansi - - -multiple { + -multiple - + -multipleunique - + -choicemultipleunique - -choicemultipleuniqueset - + -optional { if {![string is boolean -strict $v]} { error "punk::args::resolve - invalid type of value '$v' for key '$k' in @leaders line. Must be boolean @id:$DEF_definition_id" } @@ -1961,6 +2065,7 @@ tcl::namespace::eval punk::args { -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ -unindentedfields\ -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -multipleunique -choicemultipleunique -choicemultipleuniqueset\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ -unnamed\ } @@ -2051,11 +2156,13 @@ tcl::namespace::eval punk::args { -typeranges { tcl::dict::set tmp_valspec_defaults -typeranges $v } - -optional - -allow_ansi - -validate_ansistripped - -strip_ansi - - -multiple { + -multiple - + -multipleunique - + -choicemultipleunique - -choicemultipleuniqueset - + -optional { if {![string is boolean -strict $v]} { error "punk::args::resolve - invalid type of value '$v' for key '$k' in @values line. Must be boolean @id:$DEF_definition_id" } @@ -2083,6 +2190,7 @@ tcl::namespace::eval punk::args { -unindentedfields\ -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -multipleunique -choicemultipleunique -choicemultipleuniqueset\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ -unnamed\ } @@ -2414,6 +2522,7 @@ tcl::namespace::eval punk::args { -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted - -choicelabels - -choiceinfo - -minsize - -maxsize - -nocase - -multiple - + -multipleunique - -choicemultipleunique - -choicemultipleuniqueset - -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - -regexprepass - -regexprefail - -regexprefailmsg { @@ -2519,6 +2628,7 @@ tcl::namespace::eval punk::args { -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted\ -unindentedfields\ -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -multipleunique -choicemultipleunique -choicemultipleuniqueset\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ -ensembleparameter\ ] @@ -9228,7 +9338,7 @@ tcl::namespace::eval punk::args { set v_test $c_check } set choice_in_list 0 - set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? + set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval could be a list when -choicemultiple? if {!$matches_default} { if {$choiceprefix} { #can we handle empty string as a choice? It should just work - REVIEW/test @@ -9277,6 +9387,7 @@ tcl::namespace::eval punk::args { set chosen $bestmatch set choice_in_list 1 } + puts ">>>>> chosen: $chosen bestmatch: $bestmatch for c_check: $c_check choices_test: $choices_test allchoices: $allchoices" } else { set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check] if {$chosen eq "" || $chosen in $choiceprefixreservelist} { @@ -9302,9 +9413,11 @@ tcl::namespace::eval punk::args { if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { #single choice allowed per clause-member if {$is_multiple} { + puts ">>>>> existing:'$existing' element_index:$element_index choice_index:$choice_idx chosen: $chosen" if {$clause_size == 1} { #no list wrapping of single element in $dname dict - so don't index into it with element_index - lset existing $element_index $chosen + #lset existing $element_index $chosen ;#wrong - test::punk::args test: choice_multiple_with_choiceprefix. + lset existing $clause_index $chosen } else { lset existing $clause_index $element_index $chosen } @@ -10626,10 +10739,29 @@ tcl::namespace::eval punk::args::lib { Placeholder Substitutions: \$\{$varName\} \$\{[myCommand]\} - (when -allowcommands flag is given)" + (myCommand is evaluated when -allowcommands flag is given) + + If any error occurs during placeholder evaluation, the original placeholder text + is substituted in the output and the error is included in the returned dict + (if -return dict is used). + " -allowcommands -default 0 -type none -help\ - "If -allowcommands is present, placeholder can contain commands - e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" + "If -allowcommands is present, placeholder commands are evaluated and subtituted. + e.g tstr -allowcommands { \$\{plaintext0 [lindex $var 1] plaintext2\} } + + if $var is {a b c}, the result will be \"plaintext0 b plaintext2 \" + if $var does not exist the result will be \"\$\{plaintext0 [lindex $var 1] plaintext2\} \" + with an error recorded in the returned dict if -return dict is used. + + NOTE: even if -allowcommands is not present, the placeholder text is still processed for variable + substitution and escape sequence processing, so the result will not be the raw placeholder text. + The result will be \"plaintext0 [lindex {a b c} 0] plaintext2 \" + + e.g + tstr -undent 0 -allowcommands { \$\{ \\$var\\[1\\] = [lindex $var 1]\}} + $var[1] = b + " + -undent -default 1 -type boolean -help\ "undent/dedent the template lines. The longest common prefix of whitespace is removed" @@ -10702,6 +10834,14 @@ tcl::namespace::eval punk::args::lib { which expects the placeholders as individual arguments" } + -raise_errors -default 0 -type boolean -help\ + "By default, if an error occurs during placeholder evaluation, the original placeholder text + is substituted in the output and the error is included in the returned dict (if -return dict is used). + If -raise_errors is set to 1, the template will be processed and a list of errors will be collected as + normal, but if any errors are present at the end of processing, a single error will be raised with a + summary of all errors that occurred. + This can be useful for debugging or when you want to ensure that any issues with placeholder evaluation + are immediately visible and not silently included in the output." -eval -default 1 -type boolean -help\ "Whether to evaluate the \$\{\} placeholders. When -return is string, -eval should generally be set to 1. @@ -10739,6 +10879,7 @@ tcl::namespace::eval punk::args::lib { -paramindents line\ -eval 1\ -return string\ + -raise_errors 0\ ] if {"-allowcommands" in $arglist} { set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] @@ -10754,9 +10895,9 @@ tcl::namespace::eval punk::args::lib { } } dict for {k v} $arglist { - set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] + set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval -raise_errors} $k] switch -- $fullk { - -indent - -undent - -paramindents - -return - -eval { + -indent - -undent - -paramindents - -return - -eval - -raise_errors { dict set opts $fullk $v } default { @@ -10781,6 +10922,7 @@ tcl::namespace::eval punk::args::lib { set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] if {$opt_return eq ""} { } + set opt_raise_errors [dict get $opts -raise_errors] set opt_eval [dict get $opts -eval] @@ -10871,6 +11013,14 @@ tcl::namespace::eval punk::args::lib { incr idx ;#expression incr } + if {$opt_raise_errors && [dict size $errors]} { + set einfo "" + dict for {i e} $errors { + append einfo "parameter $i error: $e" \n + } + error "punk::args::lib::tstr: Errors occurred during placeholder evaluation:\n$einfo" + } + if {$opt_return eq "dict"} { return [dict create template $textchunks params $params errors $errors] } @@ -11200,17 +11350,39 @@ tcl::namespace::eval punk::args::package { set pkgname [${pkgns}::package_name] set opt_return [dict get $OPTS -return] - set all_topics [${pkgns}::about_topics] + set defined_topics [${pkgns}::about_topics] if {![dict exists $received topic]} { - set topics $all_topics + set topics $defined_topics } else { # * represents all remaining topics not explicitly mentioned. set val_topics [dict get $values topic] ;#if -multiple is true, this is a list - set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] + #set explicit_topic_prefixes [lsearch -all -inline -exact -not $val_topics "*"] + set explicit_topics [list] + set requested_topics [list] + set defined_topics_lc [lmap t $defined_topics {string tolower $t}] + foreach et $val_topics { + #topics are case insensitive. We don't expect function names from about_topics to have variations differing only in case. + #todo - enforce this by only returning the last value from about_topics for each particular topic when there are duplicates differing only in case. + #(see punk::auto_execs for example. TODO -add to template or use helper function to enforce this when processing about_topics) + if {$et eq "*"} { + lappend requested_topics "*" + continue + } + + set fulltopic_lc [tcl::prefix::match -error "" $defined_topics_lc [string tolower $et]] + if {$fulltopic_lc eq ""} { + error "punk::args::package::standard_about topic '$et' does not match any defined topics: $defined_topics" + } else { + set resolved_topic [lsearch -inline -nocase $defined_topics $fulltopic_lc] + lappend explicit_topics $resolved_topic + lappend requested_topics $resolved_topic + } + } + set topics [list] - foreach t $val_topics { + foreach t $requested_topics { if {$t eq "*"} { - foreach a $all_topics { + foreach a $defined_topics { if {$a ni $explicit_topics} { lappend topics $a } diff --git a/src/bootsupport/modules/punk/auto_exec-0.1.0.tm b/src/bootsupport/modules/punk/auto_exec-0.1.0.tm index 22486038..662656cb 100644 --- a/src/bootsupport/modules/punk/auto_exec-0.1.0.tm +++ b/src/bootsupport/modules/punk/auto_exec-0.1.0.tm @@ -47,6 +47,45 @@ tcl::namespace::eval punk::auto_exec { set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline] } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id "::punk::auto_exec::rehash" + @cmd -name "punk::auto_exec::rehash"\ + -summary\ + "Update the hash table of autoexec commands cached in ::auto_execs."\ + -help\ + {Clear/refresh the autoexec commands in the ::auto_execs array. + + This is analogous to the 'rehash' command in shells such as csh, tcsh and zsh. + It updates the shell's hash table of executable commands. + + This can be useful after installing new software, adjusting the environment PATH directories, or (on windows) making + changes to the system that may affect file type associations and their associated commands, to ensure that the autoexec + commands are up to date with the current state of the system. + + If refresh is false (the default), then all autoexec commands are cleared and will re-register as commands are called. + If refresh is true, then all existing autoexec commands are re-registered by calling auto_execok for each of them again.} + @opts + @values -min 0 -max 1 + refresh -type boolean -default 0 -help\ + "Whether to re-register existing autoexec commands by calling auto_execok for each of them again." + }] + } + proc rehash {{refresh 0}} { + global auto_execs + if {!$refresh} { + unset -nocomplain auto_execs + } else { + set names [array names auto_execs] + unset -nocomplain auto_execs + foreach nm $names { + #auto_execok_windows $nm + auto_execok $nm + } + } + return + } + variable PUNKARGS lappend PUNKARGS [list { @id -id "::punk::auto_exec::shell_open_command" @@ -347,7 +386,7 @@ tcl::namespace::eval punk::auto_exec { if {!$new_chunk} { if {$current_chunk ne "" || $current_chunk eq "" && [lindex $quoted end]} { - #we add the current chunk to the result list if it's not empty, or if it is empty but is quoted (because in that case we want to preserve it as an empty argument). + #we add the current chunk to the result list if it's not empty, or if it is empty but is quoted (because in that case we want to preserve it as an empty argument). lappend result $current_chunk lappend quoted 0 set current_chunk {} @@ -564,15 +603,17 @@ tcl::namespace::eval punk::auto_exec { user-specific association is found. Returns a dict of dicts with toplevel keys for each shell verb (e.g open, runas) and values that are dicts with keys - ${$I}type${$NI} and ${$I}value${$NI} and ${$I}scope${$NI}, where - type is determined from the registry value type (e.g sz or expand_sz) - string is the raw command string from the registry - scope is either "user" or "system" depending on whether the value was found in the user-specific registry keys or - the system registry keys. + ${$I}type${$NI} and ${$I}value${$NI} and ${$I}scope${$NI}, where: + + ${$I}type${$NI} is determined from the registry value type (e.g sz or expand_sz) + + ${$I}string${$NI} is the raw command string from the registry + + ${$I}scope${$NI} is either \"user\" or \"system\" depending on whether the value was found in the user-specific + registry keys or the system registry keys. This is somewhat like the windows 'ftype' command except that the windows command only looks for the 'open' verb and - only looks up the system association and does not take into account any user-specific - overrides. + only looks up the system association and does not take into account any user-specific overrides. The file type can be looked up using the ${$B}assoc${$N} function in this package. @@ -587,40 +628,11 @@ tcl::namespace::eval punk::auto_exec { This can be looked up using the 'assoc' function in this package." }] } - #proc ftype {filetype} { - # package require registry - - # if {$filetype eq "cplfile"} { - # #special case for cplfile (associated with .cpl files) which doesn't follow the usual pattern of having the command string under shell\open\command, - # #but instead has it under HKEY_LOCAL_MACHINE\SOFTWARE\Classes\cplfile\shell\cplopen\command. - # #There doesn't seem to be any user-specific override for this file type - # #- but we will check for one under HKEY_CURRENT_USER\Software\Classes\cplfile\shell\cplopen\command anyway for consistency with the way we check - # #for user-specific overrides for other file types. - # set key [join [list HKEY_CURRENT_USER Software Classes cplfile shell cplopen command] "\\"] - # } else { - # set key [join [list HKEY_CURRENT_USER Software Classes $filetype shell open command] "\\"] - # } - # if {![catch {registry get $key ""} raw_assoc]} { - # set tp [registry type $key ""] - # return [dict create open [dict create type $tp string $raw_assoc]] - # } else { - # #e.g Python.File - # if {$filetype eq "cplfile"} { - # set key [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes cplfile shell cplopen command] "\\"] - # } else { - # set key [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $filetype shell open command] "\\"] - # } - # if {![catch {registry get $key ""} raw_assoc]} { - # set tp [registry type $key ""] - # return [dict create type $tp string $raw_assoc] - # } else { - # return [dict create type "" string ""] ;#no association found - # } - # } - #} proc ftype {filetype} { package require registry set resultdict [dict create] + #registry queries are case insensitive but some are keys are cased differently e.g Open vs open. + #when using the verb as a key in the output dict, we need to normalize so that it is useful for lookups. We'll use lowercase for that. #e.g Python.File set shellpath [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $filetype shell] "\\"] @@ -628,8 +640,6 @@ tcl::namespace::eval punk::auto_exec { foreach verb $shellverbs { set commandkey [join [list $shellpath $verb command] "\\"] if {![catch {registry get $commandkey ""} cmdstring]} { - #registry queryies are case insensitive but some are cased differently e.g Open vs open. - #when using the verb as a key in the output dict, we need to normalize so that it is useful for lookups. We'll use lowercase for that. set verb [string tolower $verb] set tp [registry type $commandkey ""] dict set resultdict $verb [dict create type $tp value $cmdstring scope system] @@ -649,7 +659,6 @@ tcl::namespace::eval punk::auto_exec { } } } - return $resultdict } @@ -671,9 +680,9 @@ tcl::namespace::eval punk::auto_exec::lib { #} -# == === === === === === === === === === === === === === === +# == === === === === === === === === === === === === === === # Sample 'about' function with punk::args documentation -# == === === === === === === === === === === === === === === +# == === === === === === === === === === === === === === === tcl::namespace::eval punk::auto_exec { tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase variable PUNKARGS @@ -682,8 +691,7 @@ tcl::namespace::eval punk::auto_exec { lappend PUNKARGS [list { @id -id "(package)punk::auto_exec" @package -name "punk::auto_exec" -help\ - "Package - Description" + "An autoexec_ok replacement for Tcl with support for windows file type associations and command string parsing." }] namespace eval argdoc { @@ -695,26 +703,34 @@ tcl::namespace::eval punk::auto_exec { #info commands results are returned in an arbitrary order (like array keys) set topic_funs [info commands [namespace current]::get_topic_*] set about_topics [list] + #use a dict to enforce last case-variation of a topic wins. + set case_dict [dict create] foreach f $topic_funs { set tail [namespace tail $f] - lappend about_topics [string range $tail [string length get_topic_] end] + set t [string range $tail [string length get_topic_] end] + set t_lc [string tolower $tail] + dict set case_dict $t_lc $t + } + dict for {lc t} $case_dict { + lappend about_topics $t } + #Adjust this function or 'default_topics' if a different order is required return [lsort $about_topics] } proc default_topics {} {return [list Description *]} # ------------------------------------------------------------- - # get_topic_ functions add more to auto-include in about topics + # get_topic_ functions add more to auto-include in about topics # ------------------------------------------------------------- proc get_topic_Description {} { - punk::args::lib::tstr [string trim { - package punk::auto_exec - description to come.. + punk::args::lib::tstr [string trim { + package punk::auto_exec + A replacement for Tcl's builtin autoexec_ok function. } \n] } proc get_topic_License {} { - return "" + return "BSD-3-Clause" } proc get_topic_Version {} { return "$::punk::auto_exec::version" @@ -730,22 +746,41 @@ tcl::namespace::eval punk::auto_exec { } return $contributors } - proc get_topic_custom-topic {} { - punk::args::lib::tstr -return string { - A custom - topic - etc - } + proc get_topic_Notes {} { + return [string trim { + This package primarily provides advanced features on the windows platform, but some functions such as 'rehash' are + useful on any platform. + + This package provides functions to look up windows file type associations and to parse command strings with placeholders + and environment variables, which can be used as a replacement for Tcl's autoexec_ok function in certain contexts. + + The 'assoc' function looks up the associated file type for a given file extension, taking into account both user-specific + and system-wide associations in the registry. + + The 'ftype' function looks up the shell verb command values for a given file type, also taking into account both user-specific + and system-wide associations in the registry. + + The 'shell_command_as_tcl_list' function processes a command string with placeholders and environment variables and returns a + Tcl list of command and arguments with the placeholders substituted according to the specified rules. + + } \n] } + #proc get_topic_custom-topic {} { + # punk::args::lib::tstr -return string { + # A custom + # topic + # etc + # } + #} # ------------------------------------------------------------- } # we re-use the argument definition from punk::args::standard_about and override some items set overrides [dict create] dict set overrides @id -id "::punk::auto_exec::about" - dict set overrides @cmd -name "punk::auto_exec::about" + dict set overrides @cmd -name "punk::auto_exec::about" dict set overrides @cmd -help [string trim [punk::args::lib::tstr { - About punk::auto_exec + About punk::auto_exec }] \n] dict set overrides topic -choices [list {*}[punk::auto_exec::argdoc::about_topics] *] dict set overrides topic -choicerestricted 1 @@ -761,7 +796,7 @@ tcl::namespace::eval punk::auto_exec { } } # end of sample 'about' function -# == === === === === === === === === === === === === === === +# == === === === === === === === === === === === === === === # ----------------------------------------------------------------------------- @@ -776,11 +811,11 @@ namespace eval ::punk::args::register { # ----------------------------------------------------------------------------- # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::auto_exec [tcl::namespace::eval punk::auto_exec { variable pkg punk::auto_exec variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/bootsupport/modules/punk/config-0.1.tm b/src/bootsupport/modules/punk/config-0.1.tm index 8d5a5dca..3d967541 100644 --- a/src/bootsupport/modules/punk/config-0.1.tm +++ b/src/bootsupport/modules/punk/config-0.1.tm @@ -15,13 +15,16 @@ tcl::namespace::eval punk::config { namespace eval punk {namespace export config} proc _homedir {} { - if {[info exists ::env(HOME)]} { - set home [file normalize $::env(HOME)] - } else { - #not available on 8.6? ok will error out here. - set home [file tildeexpand ~] - } - return $home + return [punk::nav::fs::~] ;#will work if HOME is not set. + #may return an error if no home directory can be determined + + #if {[info exists ::env(HOME)]} { + # set home [file normalize $::env(HOME)] + #} else { + # #not available on 8.6? ok will error out here. + # set home [file tildeexpand ~] + #} + #return $home } lappend PUNKARGS [list { diff --git a/src/bootsupport/modules/punk/du-0.1.0.tm b/src/bootsupport/modules/punk/du-0.1.0.tm index 6d2eb59f..ad27135d 100644 --- a/src/bootsupport/modules/punk/du-0.1.0.tm +++ b/src/bootsupport/modules/punk/du-0.1.0.tm @@ -1712,7 +1712,7 @@ namespace eval punk::du { set errors [dict create] foreach {k v} $args { switch -- $k { - -glob - -with_sizes - -with_times { + -glob - -filedebug - -patterndebug - -link_info - -with_sizes - -with_times - -types { dict set opts $k $v } default { @@ -1766,6 +1766,7 @@ namespace eval punk::du { set types_entry [list] set types_attribute [list] set types_permission [list] + set types_REQUIRED [list] foreach t $entry_and_attribute_types { switch -- $t { f - d - l - p - s - b - c { @@ -1775,16 +1776,46 @@ namespace eval punk::du { hidden - readonly { #these are all valid attributes lappend types_attribute $t + lappend types_REQUIRED $t } r - w - x { #these are all valid permissions lappend types_permission $t + lappend types_REQUIRED $t } default { error "du_dirlisting_generic unrecognized element in -types '$t'. Known types/attributes/permissions: f d l p s b c hidden readonly r w x" } } } + + set do_sizes_d [expr {"d" in $sized_types}] + set do_sizes_f [expr {"f" in $sized_types}] + set do_sizes_l [expr {"l" in $sized_types}] + set do_times_d [expr {"d" in $timed_types}] + set do_times_f [expr {"f" in $timed_types}] + set do_times_l [expr {"l" in $timed_types}] + if {[llength $types_entry] && "d" ni $types_entry} { + set skip_dirs 1 + } else { + set skip_dirs 0 + } + if {[llength $types_entry] && "f" ni $types_entry} { + set skip_files 1 + } else { + set skip_files 0 + } + if {[llength $types_entry] && "l" ni $types_entry} { + set skip_links 1 + } else { + set skip_links 0 + } + set trequire_hidden [expr {"hidden" in $types_REQUIRED}] + set trequire_readonly [expr {"readonly" in $types_REQUIRED}] + set trequire_executable [expr {"x" in $types_REQUIRED}] + set trequire_readable [expr {"r" in $types_REQUIRED}] + set trequire_writable [expr {"w" in $types_REQUIRED}] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- # The repeated globs are a source of slowness for this function. @@ -1813,56 +1844,42 @@ namespace eval punk::du { if {$opt_glob eq "*"} { #Note - multiple glob operations with restrictions seem to be faster than looped tests like 'file isdirectory' & 'file readlink' #set parent [lindex $folders $folderidx] - if {![llength $types_entry] || "d" in $types_entry} { - #we need to check directories for hidden attribute - as on windows, not all dotfiles are hidden, and not all hidden files are dotfiles - set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} * .*] - set dirs [glob -nocomplain -dir $folderpath -types d * .*] - } - if {![llength $types_entry] || "l" in $types_entry} { - set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} * .*] - set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique - } - if {![llength $types_entry] || "f" in $types_entry} { - set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} * .*] - set files [glob -nocomplain -dir $folderpath -types f * .*] - } + set globs [list *] } else { - if {![llength $types_entry] || "d" in $types_entry} { - #we need to check directories for hidden attribute - as on windows, not all dotfiles are hidden, and not all hidden files are dotfiles - set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} $opt_glob] - set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] - } - if {![llength $types_entry] || "l" in $types_entry} { - set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} $opt_glob] - set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique - } - if {![llength $types_entry] || "f" in $types_entry} { - set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} $opt_glob] - set files [glob -nocomplain -dir $folderpath -types f $opt_glob] - } + set globs [list $opt_glob] + } + #on windows this is a lot of separate globs to perform. Using the du_dirlisting_twapi is preferred for performance on windows - but this is a fallback and for testing. + #if {![llength $types_entry] || "d" in $types_entry} {} + if {!$skip_dirs} { + #we need to check directories for hidden attribute - as on windows, not all dotfiles are hidden, and not all hidden files are dotfiles + set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} {*}$globs] + set dirs [glob -nocomplain -dir $folderpath -types d {*}$globs] + } + if {!$skip_links} { + set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} {*}$globs] + set links [glob -nocomplain -dir $folderpath -types l {*}$globs] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique + } + if {!$skip_files} { + set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} {*}$globs] + set files [glob -nocomplain -dir $folderpath -types f {*}$globs] } } else { if {$opt_glob eq "*"} { - #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink' - #set parent [lindex $folders $folderidx] - #set dirs [glob -nocomplain -dir $folderpath -types d * .*] - #set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique - #set files [glob -nocomplain -dir $folderpath -types f * .*] set globs [list * .*] } else { set globs [list $opt_glob] - #set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] - #set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique - #set files [glob -nocomplain -dir $folderpath -types f $opt_glob] } - - if {![llength $types_entry] || "d" in $types_entry} { + #we need to classify our results - unlike a standard glob * operation which returns all entries in one collection. + #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink' + #however - these are still significantly slower than a single glob with no restrictions - so we want to minimize the number of globs we do + #- but we also want to avoid doing extra work classifying entries that we will end up ignoring based on types/attributes/permissions filters. + if {!$skip_dirs} { set dirs [glob -nocomplain -dir $folderpath -types d {*}$globs] } - if {![llength $types_entry] || "l" in $types_entry} { + if {!$skip_links} { set links [glob -nocomplain -dir $folderpath -types l {*}$globs] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique } - if {![llength $types_entry] || "f" in $types_entry} { + if {!$skip_files} { set files [glob -nocomplain -dir $folderpath -types f {*}$globs] } @@ -1957,6 +1974,7 @@ namespace eval punk::du { set types_entry [list] set types_attribute [list] set types_permission [list] + set types_REQUIRED [list] foreach t $entry_and_attribute_types { switch -- $t { f - d - l - p - s - b - c { @@ -2155,7 +2173,7 @@ namespace eval punk::du { set errors [dict create] if {"windows" eq $::tcl_platform(platform)} { if {$opt_glob eq "*"} { - set globs [list * .*] + set globs [list *] } else { set globs [list $opt_glob] } @@ -2295,6 +2313,13 @@ namespace eval punk::du { #we don't classify anything as 'flaggedhidden' on unix. #it is a convention for dotfiles rather than a flag - and we'll leave the distinction for the display library + set dirs {} + set hdirs {} + set files {} + set hfiles {} + set links {} + set hlinks {} + if {$opt_glob eq "*"} { set globs [list * .*] } else { @@ -2341,6 +2366,7 @@ namespace eval punk::du { if {"$ft" in $meta_types} { foreach path [set $lvar] { if {$has_winpath && [punk::winpath::illegalname_test $path]} { + #review. we don't want to fix the path - we just want classify it as nonportable set testpath [punk::winpath::illegalname_fix $path] if {![catch {file stat $testpath arrstat} errM]} { dict set meta_dict $path [dict create shorttype $ft {*}[array get arrstat]] @@ -2350,7 +2376,7 @@ namespace eval punk::du { dict set meta_dict $path [dict create shorttype $ft {*}$empty_stat_dict] } } else { - #caller may have read perm on the containing folder - but not on child item - so file stat could raise an error + #caller may have permission to read on the containing folder - but not on child item - so file stat could raise an error if {![catch {file stat $path arrstat} errM]} { dict set meta_dict $path [dict create shorttype $ft {*}[array get arrstat]] } else { @@ -2463,28 +2489,38 @@ namespace eval punk::du { } proc du_dirlisting_undecided {folderpath args} { - if {"windows" eq $::tcl_platform(platform)} { - #jmn disable twapi - #tailcall du_dirlisting_generic $folderpath {*}$args - - package require zzzload - set loadstate [zzzload::pkg_require twapi] - if {$loadstate ni [list loading failed]} { - #either already loaded by zzload or ordinary package require - package require twapi ;#should be fast once twapi dll loaded in zzzload thread - set ::punk::du::has_twapi 1 - punk::du::active::set_active_function du_dirlisting du_dirlisting_twapi - tailcall du_dirlisting_twapi $folderpath {*}$args - } else { - if {$loadstate eq "failed"} { - puts stderr "punk::du defaulting to du_dirlisting_generic because twapi load failed" - punk::du::active::set_active_function du_dirlisting du_dirlisting_generic + switch -- $::tcl_platform(platform) { + windows { + #jmn disable twapi + #tailcall du_dirlisting_generic $folderpath {*}$args + + package require zzzload + set loadstate [zzzload::pkg_require twapi] + + if {$loadstate ni [list loading failed]} { + #either already loaded by zzload or ordinary package require + package require twapi ;#should be fast once twapi dll loaded in zzzload thread + set ::punk::du::has_twapi 1 + punk::du::active::set_active_function du_dirlisting du_dirlisting_twapi + tailcall du_dirlisting_twapi $folderpath {*}$args + } else { + if {$loadstate eq "failed"} { + puts stderr "punk::du defaulting to du_dirlisting_generic because twapi load failed" + punk::du::active::set_active_function du_dirlisting du_dirlisting_generic + } + tailcall du_dirlisting_generic $folderpath {*}$args } - tailcall du_dirlisting_generic $folderpath {*}$args } - } else { - punk::du::active::set_active_function du_dirlisting du_dirlisting_unix - tailcall du_dirlisting_unix $folderpath {*}$args + default { + #todo - macOS specific optimizations? e.g using macos metadata to determine hidden/readonly/system flags etc? + #macOS uses a case-insensitive filesystem by default like windows. + + #punk::du::active::set_active_function du_dirlisting du_dirlisting_unix + #tailcall du_dirlisting_unix $folderpath {*}$args + + punk::du::active::set_active_function du_dirlisting du_dirlisting_generic + tailcall du_dirlisting_generic $folderpath {*}$args + } } } diff --git a/src/bootsupport/modules/punk/mix/util-0.1.0.tm b/src/bootsupport/modules/punk/mix/util-0.1.0.tm index e816e1ef..9de4a33d 100644 --- a/src/bootsupport/modules/punk/mix/util-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/util-0.1.0.tm @@ -127,9 +127,14 @@ namespace eval punk::mix::util { foreach p $finalpaths { if {$has_winlnk && [file extension $p] eq ".lnk"} { set resolve_info [punk::winlnk::resolve $p] - set resolved [dict get $resolve_info link_target] + set resolved [dict get $resolve_info link_roottarget] if {$resolved ne ""} { - lappend resolved_finalpaths $resolved + if {[dict exists $resolve_info stringdata command_line_arguments]} { + puts stderr "link $p has arguments. Will cat the .lnk file itself rather than the root target." + lappend resolved_finalpaths $p + } else { + lappend resolved_finalpaths $resolved + } } else { lappend resolved_finalpaths $p } diff --git a/src/bootsupport/modules/punk/nav/fs-0.1.0.tm b/src/bootsupport/modules/punk/nav/fs-0.1.0.tm index 24dfad86..6d877c5f 100644 --- a/src/bootsupport/modules/punk/nav/fs-0.1.0.tm +++ b/src/bootsupport/modules/punk/nav/fs-0.1.0.tm @@ -157,6 +157,177 @@ tcl::namespace::eval punk::nav::fs { #[list_begin definitions] + #only lookup user_home once per interp or process + #It can be slightly expensive (for example involving network calls on windows domains) + variable user_home_cache + set user_home_cache "" + + #tilde + #These aliases work fine for interactive use - but the result is always a string internal-rep + #interp alias {} ~ {} file join $::env(HOME) ;#HOME must be capitalized to work cross platform (lowercase home works on windows - but probably not elsewhere) + #interp alias {} ~ {} apply {args {file join $::env(HOME) $args}} + namespace eval argdoc { + punk::args::define { + @id -id ::punk::nav::fs::~ + @cmd -name "punk::nav::fs::~"\ + -summary\ + "Return user's home directory as the process sees it"\ + -help\ + "Return the user's home directory path as the process sees it. + + (This is not always the same as ::env(HOME)) + + With additional arguments, return the path obtained by joining + the user's home directory with the supplied arguments. + + usage e.g + cd [~] + (change to user's home) + .// [~] .config + (change to .config directory within the user's home + and list contents.) + equivalently: + gohome .config + (gohome uses the output of ~ to determine the home directory) + + If the home directory cannot be determined due to the environment + in which the process is running, an error will be raised, as returning + an empty string is not a useful result and can cause issues if used as a path. + " + @opts + @values -min 0 -max -1 + arg -type any -optional 1 -multiple 1 + } + } + proc ~ {args} { + #review - HOME may be undefined or have been set to another value by other tools or the parent process. + #The process may even be running in a context where there is no home directory - e.g a container with no users, or a system service context. + #(we may be in a safe interp - which generally won't have env vars or filesystem access) + variable user_home_cache + if {$user_home_cache ne ""} { + set hdir $user_home_cache + #we still need to process args to join them to the home directory - but we can skip all the work of determining the home directory again. + } else { + set hdir "" + + if {[catch {auto_execok whoami} whoami_exe]} { + set whoami_exe "" + } + if {$whoami_exe eq ""} { + #try env USER or USERNAME - these are commonly set to the username on many platforms - but may not be set in all contexts. + if {[info exists ::env(USER)]} { + set user $::env(USER) + } elseif {[info exists ::env(USERNAME)]} { + set user $::env(USERNAME) + } else { + set user "" + } + } else { + #set user [exec {*}$whoami_exe] + if {[catch {exec {*}$whoami_exe} user]} { + set user "" + } + } + if {[string trim $user] ne ""} { + #normalize user for use with 'file tildeexpand ~' + #on windows, whoami may return DOMAIN\USER + #for tildeexpand to work, we need to convert this to USER@DOMAIN + if {"windows" eq $::tcl_platform(platform)} { + set parts [split $user "\\"] + #we expect only 1 or 2 parts + if {[llength $parts] == 2} { + lassign $parts domain username + + #if we use username@domain format - we get the domain controller's view of our home directory - which can be different from the local machine's view of our home directory. + #e.g file tildeexpand ~jnoble@corp can return a local non existant path like c:/users/jnoble + #but it may be c:/users/jnoble.corp - or c:/users/something_else_entirely depending on how the local machine is configured. + #It may be that the domain controller is correct if it returns a network path like \\server\users\jnoble ?? + #Network paths are not necessarily the preferred practive as of 2026 - but may still exist. + #Microsoft is encouraging the use of cloud systems - but it it unknown at this stage what sort of paths can be returned. + + #REVIEW + + set domainuser "$username@$domain" + #we can run file tildeexpand with username@domain and test if the path is writable + #this reduces the possibility that there happens to be a local user with the same name as the domain user - which would cause us to get the wrong home directory. + if {![catch {file tildeexpand ~$domainuser} path]} { + if {[file writable $path]} { + set user $domainuser + set hdir $path ;#set hdir so we don't re-lookup below. + } + } + if {$hdir eq ""} { + #for now we will use the unqualified username. + set user $username + } + + } elseif {[llength $parts] == 1} { + set user [lindex $parts 0] + } else { + #unexpected format - emit warning + puts stderr "Warning: Unexpected format of username '$user' returned by whoami. Expected format 'DOMAIN\\USER' or 'USER'. Unable to determine home directory for this user." + set user "" + } + } + + #only enter this branch if hdir wasn't resolved above for windows domain user. + if {$hdir eq "" && $user ne ""} { + #we use file tildeexpand ~user because the intention is stated in the tcl source as: + #* the intent is to retrieve (as on Unix) the system's view + #* of the home irrespective of environment settings of HOME + #* and USERPROFILE. + # - this aligns with our intention here. + if {![catch {file tildeexpand ~$user} path]} { + set hdir [punk::valcopy $path] + } else { + #tcl <= 8.6 may not have file tildeexpand. + #we now have no option but to rely on environment variables - which may not be set or may be set to an incorrect value + #as tcl <= 8.6 needs to be supported - but isn't the primary target we will allow this fallback - but raise a warning as this is not ideal. + puts stderr "punk::nav::fs::~ Warning: Unable to determine home directory for user '$user' using 'file tildeexpand ~$user'. Falling back to environment variables, which may not be set or may be incorrect. Consider upgrading to Tcl 9.0 or later for improved reliability." + if {"windows" eq $::tcl_platform(platform)} { + if {[info exists ::env(USERPROFILE)]} { + set hdir [punk::valcopy $::env(USERPROFILE)] + } else { + set hdir "" + } + } else { + if {[info exists ::env(HOME)]} { + set hdir [punk::valcopy $::env(HOME)] + } else { + set hdir "" + } + } + } + } + } + } + + if {$hdir eq ""} { + error "punk::nav::fs::~ Unable to determine home directory for user '$user'. Consider upgrading to Tcl 9.0 or later for improved reliability in home directory detection." + } + + file pathtype $hdir ;#flips internal-rep to path + if {![file isdirectory $hdir]} { + #file isdirectory should also return true if the path exists and is a symlink to a directory - but if it doesn't exist at all - or is a file - then we have a problem. + error "punk::nav::fs::~ Determined home directory path '$hdir' does not exist (or is not a directory)." + } else { + if {![file readable $hdir]} { + error "punk::nav::fs::~ Determined home directory path '$hdir' is not readable." + } + } + + set user_home_cache $hdir ;#cache only the home directory. + + set d $hdir + #use the file join 2-arg optimisation to avoid losing path-rep - probably doesn't give any advantage on all Tcl versions + #review - for what versions does/did the 2-arg version of file join not just return a string? + foreach a $args { + set d [file join $d $a] + } + file pathtype $d + return [punk::valcopy $d] + } + punk::args::define { @id -id ::punk::nav::fs::d/ @cmd -name punk::nav::fs::d/ -help\ @@ -624,9 +795,11 @@ tcl::namespace::eval punk::nav::fs { return $result } + + #---------------------------------------------------- punk::args::define { - @id -id ::punk::nav::fs::d/new - @cmd -name punk::nav::fs::d/new\ + @id -id ::punk::nav::fs::newdir + @cmd -name punk::nav::fs::newdir\ -summary\ "Create directory or directories at the specified path(s)."\ -help\ @@ -662,9 +835,9 @@ tcl::namespace::eval punk::nav::fs { created for some reason (e.g other filesystem error) then an error will be raised and processing of any remaining paths will be aborted." } - #todo - synchronize overall behaviour of d/new with that of n/new (for namespaces) - proc d/new {args} { - set argd [punk::args::parse $args withid ::punk::nav::fs::d/new] + #todo - synchronize overall behaviour of newdir with that of newns (for namespaces) + proc newdir {args} { + set argd [punk::args::parse $args withid ::punk::nav::fs::newdir] lassign [dict values $argd] leaders opts values received set paths [dict get $values path] set allow_nonportable [dict exists $received -nonportable] @@ -678,12 +851,12 @@ tcl::namespace::eval punk::nav::fs { set error_paths [list] foreach p $paths { if {!$allow_nonportable && [punk::winpath::illegalname_test $p]} { - #error "punk::nav::fs::d/new Path '$p' is not portable and may not be created without -nonportable option" + #error "punk::nav::fs::newdir Path '$p' is not portable and may not be created without -nonportable option" lappend error_paths [list $p "Path '$p' is not portable and may not be created without -nonportable option"] continue } if {[string first \0 $p] != -1} { - #error "punk::nav::fs::d/new Path '$p' contains null character which is not allowed" + #error "punk::nav::fs::newdir Path '$p' contains null character which is not allowed" lappend error_paths [list $p "Path '$p' contains null character which is not allowed"] continue } @@ -699,7 +872,7 @@ tcl::namespace::eval punk::nav::fs { set parent [file dirname $parent] } if {![file writable $parent]} { - #error "punk::nav::fs::d/new Cannot create directory '$fullpath' as parent '$parent' is not writable" + #error "punk::nav::fs::newdir Cannot create directory '$fullpath' as parent '$parent' is not writable" lappend error_paths [list $fullpath "Cannot create directory '$fullpath' as parent '$parent' is not writable"] continue } @@ -713,7 +886,7 @@ tcl::namespace::eval punk::nav::fs { set m [lindex $e 1] append path_error_display " Path: '$p' Error: $m\n" } - error "punk::nav::fs::d/new One or more supplied paths were invalid or not writable:\n$path_error_display" + error "punk::nav::fs::newdir One or more supplied paths were invalid or not writable:\n$path_error_display" } set num_created 0 @@ -730,17 +903,56 @@ tcl::namespace::eval punk::nav::fs { incr num_created } if {$error_string ne ""} { - error "punk::nav::fs::d/new $error_string\n$num_created directories out of [llength $fullpath_list] were created successfully before the error was encountered." + error "punk::nav::fs::newdir $error_string\n$num_created directories out of [llength $fullpath_list] were created successfully before the error was encountered." } #display summaries of created directories (which may have already existed) by reusing d/ to get info on them. set query_paths [lmap v $paths {string cat $v "/*"}] d/ / {*}$query_paths } + #---------------------------------------------------- + - #todo use unknown to allow d/~c:/etc ?? - proc d/~ {args} { - set home $::env(HOME) + punk::args::define { + @id -id ::punk::nav::fs::lib::gohome + @cmd -name punk::nav::fs::lib::gohome\ + -summary\ + "Navigate to a path relative to the current user's home directory."\ + -help\ + "Navigate to a path relative to the user's home directory. + + This may usually correspond to the HOME environment variable, but some + tools may have pointed HOME elsewhere, so the home directory is determined + based on the current user as determined using the whoami command, which is + almost universally available on platforms that Tcl runs on, and should be + unaffected by any changes to environment variables. + + This is a convenience function for quickly navigating to commonly used + locations within the home directory, without having to type out the full + path or use environment variables. + + Like the './' command, this navigates to the folder and then lists the sub-directories, + with a summary of the number of sub-directories and files, and total file size in bytes. + + " + @values -min 1 -max -1 + path -type string -optional 1 -multiple 1 -help\ + "Path relative to home directory to navigate to. + If the path does not exist, or is not a directory, then an error will be raised. + Examples: + gohome - will navigate to $HOME + (equivalent: gohome .) + gohome subdir1/subdir2 - will navigate to $HOME/subdir1/subdir2 + (equivalent: gohome subdir1 subdir2) + gohome subdir1 - will navigate to $HOME/subdir1 + + An absolute path is also accepted, but then the navigation is not relative to the home + directory and is effectively just a normal navigation to the specified path. + (equivalent to using ./ ) + " + } + proc gohome {args} { + set home [punk::nav::fs::~] set target [file join $home {*}$args] if {![file isdirectory $target]} { error "Folder $target not found" @@ -1731,10 +1943,11 @@ tcl::namespace::eval punk::nav::fs { if {![catch {package require punk::winlnk}]} { set target_type "file" ;#default/fallback - set shortcutinfo [punk::winlnk::resolve $fname] - if {[dict exists $shortcutinfo link_target]} { + set shortcutinfo [punk::winlnk::resolve $fname] ;#will always return a dict. Will only contain error key if there was an error. + + if {[dict exists $shortcutinfo link_roottarget]} { set is_valid_lnk 1 - set tgt [dict get $shortcutinfo link_target] + set root_tgt [dict get $shortcutinfo link_roottarget] set link_target_type [dict get $shortcutinfo target_type] switch -- $link_target_type { file { @@ -1744,12 +1957,12 @@ tcl::namespace::eval punk::nav::fs { set target_type "directory" } unknown { - #fall back to checking attributes and filesystem if we have a link_target but no target_type - if {[file exists $tgt]} { + #fall back to checking attributes and filesystem if we have a link_roottarget but no target_type + if {[file exists $root_tgt]} { #file type could return 'link' - we will use isfile/isdirectory - if {[file isfile $tgt]} { + if {[file isfile $root_tgt]} { set target_type file - } elseif {[file isdirectory $tgt]} { + } elseif {[file isdirectory $root_tgt]} { set target_type directory } else { set target_type file ;## ? @@ -1761,26 +1974,32 @@ tcl::namespace::eval punk::nav::fs { } } } else { - #no link_target - probably an ordinary file - but there could have been some other error in reading the binary windows lnk format. + #no link_roottarget - probably an ordinary file - but there could have been some other error in reading the binary windows lnk format. set is_valid_lnk 0 } if {$is_valid_lnk} { switch -- $target_type { file { set display [dict get $fdict display] - set display "$fshortcut_style$display (shortcut $tgt)" ;# + if {[dict exists $shortcutinfo stringdata command_line_arguments]} { + set display "$fshortcut_style$display (shortcut to $root_tgt [dict get $shortcutinfo stringdata command_line_arguments])" + } else { + set display "$fshortcut_style$display (shortcut $root_tgt)" ;# + } dict set fdict display $display lappend finfo_plus $fdict } directory { #target of link is a dir - for display/categorisation purposes we want to see it as a dir #will be styled later based on membership of dir_shortcuts + #review: we shouldn't see a link to a dir that also has command_line_arguments + #- but if we do, we will just ignore the command_line_arguments for now and treat as a directory shortcut. lappend dirs $fname lappend dir_shortcuts $fname } } } else { - #we were unable to get link_target - but we still need to check if it failed the header check (then assume not intended to be a windows shell lnk) or for some other reason. + #we were unable to get link_roottarget - but we still need to check if it failed the header check (then assume not intended to be a windows shell lnk) or for some other reason. if {[dict exists $shortcutinfo error]} { if {[dict get $shortcutinfo error] ne "lnk_header_check_failed"} { #Presumably there is a valid lnk header, but some unexpected error occurred - show it in the display for the file @@ -1794,9 +2013,10 @@ tcl::namespace::eval punk::nav::fs { lappend finfo_plus $fdict } } else { - #shouldn't ever happen. If no error, then there should have been a link_target + #shouldn't ever happen. If no error, then there should have been a link_roottarget #report and move on - puts stderr "Unexpected error in result of parsing binary format for $fname" + puts stderr "Unexpected error in result of parsing binary format for $fname." + puts stderr "Result was [showdict $shortcutinfo]" lappend finfo_plus $fdict } } @@ -2079,6 +2299,7 @@ tcl::namespace::eval punk::nav::fs::system { } +interp alias {} ~ {} punk::nav::fs::~ interp alias {} ./ {} punk::nav::fs::d/ / interp alias {} d/ {} punk::nav::fs::d/ / interp alias {} .// {} punk::nav::fs::d/ // @@ -2093,10 +2314,12 @@ interp alias {} dirfiles {} punk::nav::fs::dirfiles interp alias {} dirfiles_dict {} punk::nav::fs::dirfiles_dict interp alias {} fglob {} punk::nav::fs::fglob -interp alias {} ./new {} punk::nav::fs::d/new -interp alias {} d/new {} punk::nav::fs::d/new -interp alias {} ./~ {} punk::nav::fs::d/~ -interp alias {} d/~ {} punk::nav::fs::d/~ +interp alias {} newdir {} punk::nav::fs::newdir + +#this also conflicts with auto_cd as there could be a local folder (or file) called ~. +interp alias {} gohome {} punk::nav::fs::gohome + +#review interp alias {} x/ {} punk::nav::fs::x/ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ diff --git a/src/bootsupport/modules/punk/nav/ns-0.1.0.tm b/src/bootsupport/modules/punk/nav/ns-0.1.0.tm index 16cb13a1..6a336808 100644 --- a/src/bootsupport/modules/punk/nav/ns-0.1.0.tm +++ b/src/bootsupport/modules/punk/nav/ns-0.1.0.tm @@ -94,7 +94,8 @@ tcl::namespace::eval punk::nav::ns { if {[llength $ensemble_info] > 0} { #this namespace happens to match ensemble command. #todo - keep cache of encountered ensembles from commands.. and examine namespace in the configure info. - set ns_display "\n[a+ yellow bold]$ns_current (ensemble)[a+]" + #don't rely on a+ alias here. + set ns_display "\n[punk::ansi::a+ yellow bold]$ns_current (ensemble)[punk::ansi::a+]" } } } @@ -103,11 +104,86 @@ tcl::namespace::eval punk::nav::ns { return $out } - #create possibly nested namespace structure - but only if not already existant - proc n/new {args} { + #create possibly nested namespace structure(s) - todo: allow specifying namespaces or which already or partially already exist. + #todo - sync with newdir behaviour. + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::punk::nav::ns::newns + @cmd -name punk::nav::ns::newns\ + -summary\ + "Create namespace or namespaces at the specified path(s)."\ + -help\ + "This command creates namespaces at the specified path(s). + If any part of the specified path does not exist, then it will be created as well. + If a specified path already exists, then it will be left as-is and no error will be raised. + + A summary line is returned for each created namespace, with the full path of the created + namespace and a status line indicating the number of child namespaces, commands and vars in + the namespace if it already existed (or showing 0 for all if it was just created). + (summary incomplete - todo)" + -force -type none\ + -help\ + "Allows creation of namespaces which may be unwise/problematic, such as empty string + or namespaces with leading colons. + Use with caution and only when you know what you are doing. + If -force is not supplied, then an error will be raised if any supplied + path is problematic and no namespaces will be created." + @values -min 1 -max -1 -type string + path -type string -multiple 1 -optional 0 -help\ + "Path(s) (possibly with namespace separator ::) to create. + Can be absolute or relative to current namespace. + If any path is rejected, then no namespaces will be created. + + If a namespace or part of a namespace already exists, then it will be left as-is and no + error will be raised. + + If despite passing the name tests, a namespace cannot be created for some reason then an + error will be raised and processing of any remaining paths will be aborted." + }] + } + proc newns {args} { + set argd [punk::args::parse $args withid ::punk::nav::ns::newns] + lassign [dict values $argd] _leaders opts values _received + if {[dict exists $opts -force]} { + set opt_force [dict get $opts -force] + } else { + set opt_force 0 + } + set paths [dict get $values path] + + variable ns_current + + #todo: like newdir we want to try to perform an all-or-nothing operation - so first validate all namespaces to be created before creating any of them. + + set ns [lindex $paths 0] ;#temporary - full implementation will loop through $paths. + set is_absolute [string match ::* $ns] + if {$is_absolute} { + set nspath $ns + } else { + if {[string match :* $ns]} { + #todo - disallow by default and require flag to force. + #we also should disallow by default ::: (or any odd multiple? perhaps even :::: for empty ns should require -force) in between segments. + puts stderr "newns WARNING namespace with leading colon '$ns' is likely to have unexpected results" + } + set nspath [nsjoin $ns_current $ns] + } + + set ns_exists [nseval [nsprefix $nspath] [list ::tcl::namespace::exists [nstail $nspath] ]] + + if {$ns_exists} { + error "Namespace $nspath already exists" + } + #tcl::namespace::eval [nsprefix $nspath] [list tcl::namespace::eval [nstail $nspath] {}] + nseval [nsprefix $nspath] [list ::tcl::namespace::eval [nstail $nspath] {}] + + #display summaries of created directories (which may have already existed) by reusing d/ to get info on them. + set query_paths [lmap v $paths {string cat $v "::*"}] + ns/ / {*}$query_paths + } + proc newns_old {args} { variable ns_current if {![llength $args]} { - error "usage: :/new \[ ...\]" + error "usage: newns \[ ...\]" } set a1 [lindex $args 0] set is_absolute [string match ::* $a1] @@ -115,7 +191,7 @@ tcl::namespace::eval punk::nav::ns { set nspath [nsjoinall {*}$args] } else { if {[string match :* $a1]} { - puts stderr "n/new WARNING namespace with leading colon '$a1' is likely to have unexpected results" + puts stderr "newns WARNING namespace with leading colon '$a1' is likely to have unexpected results" } set nspath [nsjoinall $ns_current {*}$args] } @@ -130,6 +206,7 @@ tcl::namespace::eval punk::nav::ns { n/ $nspath } + #nn/ ::/ nsup/ - back up one namespace level proc nsup/ {v args} { variable ns_current @@ -160,14 +237,13 @@ tcl::namespace::eval punk::nav::ns { interp alias {} n/ {} punk::nav::ns::ns/ / interp alias {} n// {} punk::nav::ns::ns/ // interp alias {} n/// {} punk::nav::ns::ns/ /// -interp alias {} n/new {} punk::nav::ns::n/new +interp alias {} newns {} punk::nav::ns::newns interp alias {} nn/ {} punk::nav::ns::nsup/ / interp alias {} nn// {} punk::nav::ns::nsup/ // if 0 { -#we can't have ::/ without just plain / which is confusing. interp alias {} :/ {} punk::nav::ns::ns/ / interp alias {} :// {} punk::nav::ns::ns/ // -interp alias {} :/new {} punk::nav::ns::n/new +#we can't have ::/ without just plain / which is confusing. interp alias {} ::/ {} punk::nav::ns::nsup/ / interp alias {} ::// {} punk::nav::ns::nsup/ // } diff --git a/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/bootsupport/modules/punk/ns-0.1.0.tm index 883f82de..b90c3b3b 100644 --- a/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/bootsupport/modules/punk/ns-0.1.0.tm @@ -3416,8 +3416,8 @@ y" {return quirkykeyscript} lappend usageinfo $c set found_documentation 1 } - #todo - alias to an alias - #e.g n/new jjj + #todo? - alias to an alias + #e.g newns jjj # interp alias "" ::jjj::corp2 "" ::corp #todo -pseudocode #cmdwhich id diff --git a/src/bootsupport/modules/punk/winlnk-0.1.1.tm b/src/bootsupport/modules/punk/winlnk-0.1.1.tm index 7ad2ba89..6c31f56a 100644 --- a/src/bootsupport/modules/punk/winlnk-0.1.1.tm +++ b/src/bootsupport/modules/punk/winlnk-0.1.1.tm @@ -75,6 +75,10 @@ tcl::namespace::eval punk::winlnk { #[para] Core API functions for punk::winlnk #[list_begin definitions] + #todo - review internal API. + #A lot of these functions accept the raw contents of a .lnk file. + #It may make sense to use an OO approach to avoid reparsing of contents when calling multiple functions on the same .lnk file. + variable magic_HeaderSize "0000004C" ;#HeaderSize MUST equal this variable magic_LinkCLSID "00021401-0000-0000-C000-000000000046" ;#LinkCLSID MUST equal this @@ -853,14 +857,14 @@ tcl::namespace::eval punk::winlnk { set suffix_path "" set linkinfocontent [dict get $linkinfo_content_dict content] set next_start [dict get $linkinfo_content_dict next_start] ;#location of section following LinkInfo (Location information) - this will be the Data Strings. - set link_target "" + set link_roottarget "" set linkfields [dict create] if {$linkinfocontent ne ""} { set linkfields [LinkInfo_get_fields $linkinfocontent] set localbase_path [dict get $linkfields localbasepath] set suffix_path [dict get $linkfields commonpathsuffix] if {"windows" eq $::tcl_platform(platform)} { - set link_target [file join $localbase_path $suffix_path] + set link_roottarget [file join $localbase_path $suffix_path] } else { #review - calling mount and parsing its output every time we parse a .lnk file makes this slow on large folders with .lnk files # - we may want to cache the results of mount for some period of time or until we detect a change in the system's mounts (e.g. by monitoring /proc/mounts for changes or using a filesystem watcher on /mnt) @@ -868,24 +872,24 @@ tcl::namespace::eval punk::winlnk { if {[regexp {([a-zA-Z]):\\(.*)} $localbase_path _match drive_letter tail]} { set localbase_path [string map {\\ /} $localbase_path] set tail [string trimleft [string map {\\ /} $tail] /] - set link_target "" + set link_roottarget "" #shortcut basepath is a windows path with drive letter - try to resolve it on unix by looking for a corresponding mount from fstab or a point under /mnt set mountinfo [exec mount] foreach line [split $mountinfo "\n"] { #review - a more specific mount target might exist that includes the drive letter as part of the mount point name and is a longer prefix of the localbase_path #- we should probably look for the longest prefix match rather than just the drive letter if {[regexp -nocase -- [string cat ^$drive_letter {:\\\s+on\s+(\S+)}] $line _match mount_point]} { - set link_target [file join $mount_point $tail $suffix_path] + set link_roottarget [file join $mount_point $tail $suffix_path] break } } - if {$link_target eq ""} { + if {$link_roottarget eq ""} { #review - under what circumstances could this happen? If the drive letter doesn't match any mount points, then /mnt/drive_letter should generally already have been found above above # - However, it may be possible for /mnt/drive_Letter to still exist even if it's not reflected in the output of mount or the output of mount is in an unexpected format. #nothing in mount result matches the drive letter - try looking for a mount point under /mnt with the drive letter as the name if {[file exists /mnt/$drive_letter]} { - set link_target [file join /mnt/$drive_letter $tail $suffix_path] + set link_roottarget [file join /mnt/$drive_letter $tail $suffix_path] } else { if {$drive_letter eq [string tolower $drive_letter]} { set op_drive_letter [string toupper $drive_letter] @@ -893,20 +897,20 @@ tcl::namespace::eval punk::winlnk { set op_drive_letter [string tolower $drive_letter] } if {[file exists /mnt/$op_drive_letter]} { - set link_target [file join /mnt/$op_drive_letter $tail $suffix_path] + set link_roottarget [file join /mnt/$op_drive_letter $tail $suffix_path] } else { #leave as is except for backslashes converted to forward #- probably won't resolve correctly unless the unix system has a folder named drive_letter: in the current folder with a copy of the original filestructure. - set link_target [file join $localbase_path $suffix_path] + set link_roottarget [file join $localbase_path $suffix_path] } } } else { - #shortcut basepath is a windows path with drive letter and we found a matching mount point - link_target is set to the resolved path + #shortcut basepath is a windows path with drive letter and we found a matching mount point - link_roottarget is set to the resolved path } } else { #shortcut basepath doesn't match expected windows path format - just join it with the suffix and hope for the best #could be something like a network path or it could be something else entirely - set link_target [file join $localbase_path $suffix_path] + set link_roottarget [file join $localbase_path $suffix_path] } } } @@ -929,14 +933,14 @@ tcl::namespace::eval punk::winlnk { set target_type [dict get $target_type_info type] set target_type_mech [dict get $target_type_info mechanism] if {$target_type eq "unknown"} { - if {[file exists $link_target]} { - set target_type [file type $link_target] + if {[file exists $link_roottarget]} { + set target_type [file type $link_roottarget] set target_type_mech "filesystem" } } set result [dict create\ - link_target $link_target\ + link_roottarget $link_roottarget\ link_flags $flags_enabled\ file_attributes $file_attributes\ creation_time [Header_Get_CreationTime $contents]\ @@ -1017,7 +1021,7 @@ tcl::namespace::eval punk::winlnk { package require punk::lib #punk::lib::showdict [resolve $path] */@* set field_queries [dict create\ - link_target link_target\ + link_roottarget link_roottarget\ link_flags link_flags/@*\ file_attributes file_attributes\ creation_time creation_time\ @@ -1055,32 +1059,33 @@ tcl::namespace::eval punk::winlnk { @id -id ::punk::winlnk::target @cmd -name punk::winlnk::target\ -summary\ - "Return the target path of a .lnk file (windows shortcut)"\ + "Return the target path/commandline of a .lnk file (windows shortcut)"\ -help\ - "Return the target path of the .lnk file specified in path. + "Return the target path/commandline of the .lnk file specified in path. This is a convenience function that extracts the target path from the .lnk file and returns it directly, without all the additional information that resolve provides. If the .lnk header check fails, then - the .lnk file probably isn't really a shortcut file and an error message will be returned. - - Incomplete! - needs to process arguments when HasArguments link flag is set and append the arguments to the target path. - - e.g for a shortcut to 'START /D ...' the target will currently just return a path to cmd.exe - which is insufficient." + the .lnk file probably isn't really a shortcut file and an error message will be returned." @values -min 1 -max 1 path -type string -help "Path to the .lnk file to resolve" }] } + #consider a shortcut to the following: # START /D ^"C:\tcl\bin^" wish.exe c:\cmdfiles\ftp.tcl" - # the target currently only returns c:/Windows/System32/cmd.exe. + # the link_roottarget is c:/Windows/System32/cmd.exe. + proc target {path} { - #*** !doctools - #[call [fun target] [arg path] ] - #[para]Return the target path of the .lnk file specified in path set info [resolve $path] if {[dict exists $info error]} { error [dict get $info error] } else { - return [dict get $info link_target] + set roottarget [dict get $info link_roottarget] + if {[dict exists $info stringdata command_line_arguments]} { + set arguments [dict get $info stringdata command_line_arguments] + return "$roottarget $arguments" + } else { + return $roottarget + } } } @@ -1094,7 +1099,9 @@ tcl::namespace::eval punk::winlnk { } proc Get_target_type {content file_attributes} { - #determine type based on info in the .lnk file, such as file attributes and link flags + #determine target file/directory/link type based on info in the .lnk file, such as file attributes and link flags + #review - a .lnk may target an executable with arguments. + #In this case, the target type may be considered a file (the executable) but it may also be useful to indicate that it's a link to an executable with arguments(?). if {"DIRECTORY" in $file_attributes} { return [dict create type directory mechanism file_attributes]" @@ -1104,31 +1111,31 @@ tcl::namespace::eval punk::winlnk { set iteminfo [Get_LinkTargetIDList_iteminfo $content] if {[llength $iteminfo] > 0} { set first_item [lindex $iteminfo 0] - set first_item_type [dict get $first_item type] + set first_item_type [dict get $first_item typehex] set saw_2f 0 switch -- $first_item_type { "1F" { #plain files and folders always seem to have a first item type of 1F #so does "local disk" - set type_so_far "unknown" - #For a file, we may first see multiple items of type 32 (directory) as we go through the folder structure, - #and then finally an item of type 31 (file) at the end. + set target_type_so_far "unknown" + #For a file, we may first see multiple items of typehex 32 (directory) as we go through the folder structure, + #and then finally an item of typehex 31 (file) at the end. #For a network location, we may see an item of type 2F. #So we need to loop through all the items and keep track of what we've seen so far. foreach item $iteminfo { - set item_type [dict get $item type] - if {$item_type eq "31"} { - set type_so_far "directory" - } elseif {$item_type eq "32"} { + set item_type_hex [dict get $item typehex] + if {$item_type_hex eq "31"} { + set target_type_so_far "directory" + } elseif {$item_type_hex eq "32"} { return [dict create type file mechanism idlist] - } elseif {$item_type eq "2F"} { + } elseif {$item_type_hex eq "2F"} { set saw_2f 1 } } - if {$type_so_far eq "unknown" && $saw_2f} { + if {$target_type_so_far eq "unknown" && $saw_2f} { return [dict create type "local disk" mechanism idlist] } - return [dict create type $type_so_far mechanism idlist] + return [dict create type $target_type_so_far mechanism idlist] } } return [dict create type "unknown" mechanism idlist] diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index 5a7824f0..ebfb673f 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -35,29 +35,13 @@ namespace eval punk { " } - proc rehash {{refresh 0}} { - global auto_execs - if {!$refresh} { - unset -nocomplain auto_execs - } else { - set names [array names auto_execs] - unset -nocomplain auto_execs - foreach nm $names { - auto_execok_windows $nm - } - } - return - } proc ::punk::auto_execok_original name [info body ::auto_execok] variable better_autoexec - #set better_autoexec 0 ;#use this var via better_autoexec only - #proc ::punk::auto_execok_windows name { - # ::punk::auto_execok_original $name - #} + #use this var via better_autoexec only set better_autoexec 1 proc ::punk::auto_execok_windows name { ::punk::auto_execok_better $name @@ -166,14 +150,14 @@ namespace eval punk { proc ::punk::auto_execok_windows name { ::punk::auto_execok_better $name } - punk::rehash + punk::auto_exec::rehash } elseif {!$onoff && ($onoff != $better_autoexec)} { puts "Turning off better_autoexec - search extension then PATH" set better_autoexec 0 proc ::punk::auto_execok_windows name { ::punk::auto_execok_original $name } - punk::rehash + punk::auto_exec::rehash } else { puts "no change" } @@ -182,6 +166,16 @@ namespace eval punk { proc auto_execok_better name { + #review - we have a gneral problem of auto_exec caching negative results for relative paths. + #A failed resolution of a relative path should not generate an entry in ::auto_execs. + #This happens in plain tclsh - so we need to determine where in Tcl this happens and fix it there. + #Simply returning an empty string here will still result in a negative cache entry. + #we want to cache negative results for absolute paths or plain filenames with no file-separator. + #e.g ./doesntexist.exe should not be cached as not found, but should be re-resolved every time. (cwd dependent) + #e.g doesntexist.exe should be cached as not found, because it will always be not found until it appears in the PATH. + #i.e it is required to prefix with ./ to exec a file in the current directory. (similar to unix shells) + + global auto_execs env tcl_platform #for now at least, auto_execok_better is windows-specific. package require punk::auto_exec @@ -213,7 +207,16 @@ namespace eval punk { } if {[llength [file split $name]] != 1} { + #----------------------------------------------------- #has a path component - could be relative or absolute. + #----------------------------------------------------- + if {[file pathtype $name] eq "relative"} { + #don't cache negative result for any relative paths - as they may become valid if the file appears in the relative location, or if the user changes directory and the same relative path points to a different file. + #our only way to do this is by cooperating with the unknown handler. + set auto_execs($name) "for_unknown_handler by punk::auto_exec relative_path - file existence should be re-checked at call time" + return $auto_execs($name) + } + if {[string tolower [file extension $name]] eq ".lnk"} { #special case .lnk #todo - consider working directory or other properties of link before launching? @@ -246,11 +249,11 @@ namespace eval punk { set associnfo [punk::auto_exec::shell_open_command $test_ext] set valuetype [dict get $associnfo type] set assoc [dict get $associnfo value] - set ftype [dict get $associnfo filetype] + set windows_file_type [dict get $associnfo filetype] if {$assoc eq ""} { return [set auto_execs($name) [list $file]] } else { - if {[file pathtype $target] eq "relative" && $ftype eq "InternetShortcut"} { + if {[file pathtype $target] eq "relative" && $windows_file_type eq "InternetShortcut"} { #special case InternetShortcut - cannot accept relative path - so we can't cache it in auto_execs if we used a relative path to launch #if we return an empty string - the auto_exec will fail to launch this every time. #The best we can do is return a token for the 'unknown' process to detect and re-resolve the path every time. @@ -260,7 +263,7 @@ namespace eval punk { #e.g ::auto_execs(./link.url) = some.exe c:/desktop/link.url #this would be wrong if the user changed directory and tried to run ./link.url again on a different file with the same name # - as the cached path would no longer be correct. - return [set auto_execs($name) "(resolve_in_unknown_handler) punk::auto_exec absolute_path required"] + return [set auto_execs($name) "for_unknown_handler by punk::auto_exec absolute_path required"] } puts stderr "auto_execok_better: (review required) assoc $assoc for file $file ext $test_ext" set run [punk::auto_exec::shell_command_as_tcl_list -type $valuetype $assoc $file] ;# -workingdir [pwd] vs path of script? @@ -269,6 +272,8 @@ namespace eval punk { } } } + #cache negative result for absolute paths - as they will always point to the same location, so if they don't exist now, they won't exist later. + set auto_execs($name) "" return "" } @@ -559,7 +564,7 @@ if {![llength [info commands ::ansistring]]} { package require punk::repl::codethread package require punk::config #package require textblock -package require punk::console ;#requires Thread +catch {package require punk::console} ;#requires Thread - will not work in safe interps. package require punk::ns package require punk::winpath ;# for windows paths - but has functions that can be called on unix systems package require punk::repo @@ -5396,27 +5401,54 @@ namespace eval punk { } else { set repl_runid [punk::get_repl_runid] #set ::punk::last_run_display [list] - if {$new eq "(resolve_in_unknown_handler) punk::auto_exec absolute_path required"} { - #re-resolve. - puts "(unknown-handler): auto_execok for $name requires absolute path. Re-resolving $name with absolute path." + set resolved $new + if {[string match "for_unknown_handler *" $new]} { set ext [file extension $name] - set associnfo [punk::auto_exec::shell_open_command $ext] - set valuetype [dict get $associnfo type] - set assoc [dict get $associnfo value] - set ftype [dict get $associnfo filetype] - set fullpath [file normalize $name] - #at least for .url files - long paths (paths with multiple spaces?) can fail to run. Using the short path seems to fix this. - #This seems hacky but anyway.. - set attributes [file attributes $fullpath] - if {[dict exists $attributes -shortname]} { - set fullpath [dict get $attributes -shortname] + if {[string tolower $ext] eq ".lnk"} { + #for .lnk files we can often resolve the target path without needing to execute the shell open command + #- which is desirable because it allows us to avoid the absolute path requirement for unknown-handler auto_execok commands, + #which is desirable because it allows us to support relative paths and paths with environment variables in them + #(e.g for .lnk files that point to executables with environment variables in the path) + set targetinfo [punk::winlnk::resolve $name] + if {[dict exists $targetinfo link_roottarget]} { + set resolved [dict get $targetinfo link_roottarget] + #arguments? + } else { + puts "(unknown-handler): failed to resolve .lnk target for $name. Falling back to shell open command resolution, which may fail if absolute path is required." + } + } else { + #re-resolve. + set associnfo [punk::auto_exec::shell_open_command $ext] + set registry_valuetype [dict get $associnfo type] ;#sz vs expand_sz + set command_spec [dict get $associnfo value] + set windows_file_type [dict get $associnfo filetype] + if {[string match "*absolute_path required" $new]} { + puts "(unknown-handler): auto_execok for $name requires absolute path. Re-resolving $name with absolute path." + set fullpath [file normalize $name] + #at least for .url files - long paths (paths with multiple spaces?) can fail to run. Using the short path seems to fix this. + #This seems hacky but anyway.. + set attributes [file attributes $fullpath] + if {[dict exists $attributes -shortname]} { + set fullpath [dict get $attributes -shortname] + } + set resolved [punk::auto_exec::shell_command_as_tcl_list -type $registry_valuetype $command_spec $fullpath] + } else { + #todo + set newnorm [file normalize $name] + puts stderr "(unknown-handler): re-resolving $name with auto_execok $newnorm" + set resolved [auto_execok $newnorm] + } } - set new [punk::auto_exec::shell_command_as_tcl_list -type $valuetype $assoc $fullpath] } - + if {$resolved eq ""} { + #resolved may be emptyif auto_execok returns an empty string. + dict set ::tcl::UnknownOptions -code error + set ::tcl::UnknownResult "unresolved path '$name'" + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } set redir ">&@stdout <@stdin" - uplevel 1 [list ::catch [concat exec $redir $new [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions] + uplevel 1 [list ::catch [concat exec $redir $resolved [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions] #we can't detect stdout/stderr output from the exec #for now emit an extra \n on stderr #todo - there is probably no way around this but to somehow exec in the context of a completely separate console @@ -5502,8 +5534,7 @@ namespace eval punk { set default_cmd_search 0 if {$default_cmd_search} { if {[llength $cmds] == 1} { - uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] \ - ::tcl::UnknownResult ::tcl::UnknownOptions] + uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] ::tcl::UnknownResult ::tcl::UnknownOptions] dict incr ::tcl::UnknownOptions -level return -options $::tcl::UnknownOptions $::tcl::UnknownResult } @@ -6779,46 +6810,6 @@ namespace eval punk { - #tilde - #These aliases work fine for interactive use - but the result is always a string int-rep - #interp alias {} ~ {} file join $::env(HOME) ;#HOME must be capitalized to work cross platform (lowercase home works on windows - but probably not elsewhere) - #interp alias {} ~ {} apply {args {file join $::env(HOME) $args}} - namespace eval argdoc { - punk::args::define { - @id -id ::punk::~ - @cmd -name "punk::~"\ - -summary\ - "Return home directory"\ - -help\ - "Return the home directory path. With additional arguments, - return the path obtained by joining the home directory with - the supplied arguments. - - usage e.g - cd [~] - (change to home directory) - .// [~] .config - (change to .config directory within home directory - and list contents.) - " - @opts - @values -min 0 -max -1 - arg -type any -optional 1 -multiple 1 - } - } - proc ~ {args} { - set hdir [punk::valcopy $::env(HOME)] - file pathtype $hdir - set d $hdir - #use the file join 2-arg optimisation to avoid losing path-rep - probably doesn't give any advantage on all Tcl versions - #review - for what versions does/did the 2-arg version of file join not just return a string? - foreach a $args { - set d [file join $d $a] - } - file pathtype $d - return [punk::valcopy $d] - } - interp alias {} ~ {} punk::~ #maint - punk::args has similar @@ -7735,12 +7726,20 @@ namespace eval punk { -limit -type int -default 20 -help\ "When multiple values are passed to inspect - limit the number of elements displayed in -channel output. + When truncation has occured an elipsis indication (...) will be appended. e.g - .= lseq 20 to 50 by 3 |> .=>* inspect -limit 4 -- |> .=>* tcl::mathop::+ - (11) 20 23 26 29... + ${[punk::args::helpers::example { - - 385 + .= lseq 20 to 50 by 3 |> .=>* inspect -limit 4 -- |> .=>* tcl::mathop::+ + (11) 20 23 26 29... + + - 385 + + }]} + + If the current pipeline data is not a list, the limit is applied to the + number of lines in the pipeline value. For no limit - use -limit -1 " @@ -7881,11 +7880,11 @@ namespace eval punk { } if {$showcount} { set displaycount "[a purple bold]($count)[a] " - if {$showcount} { - set countspace [expr {[string length $count] + 3}] ;#lhs margin size of count number plus brackets and one space - set margin [string repeat " " $countspace] - set displayval [string map [list \r "" \n "\n$margin"] $displayval] - } + #if {$showcount} { + # set countspace [expr {[string length $count] + 3}] ;#lhs margin size of count number plus brackets and one space + # set margin [string repeat " " $countspace] + # set displayval [string map [list \r "" \n "\n$margin"] $displayval] + #} } else { set displaycount "" } @@ -7934,10 +7933,13 @@ namespace eval punk { } if {![string length $more]} { - puts $channel "$displaycount$label$displayval[a]" + #puts $channel "$displaycount$label$displayval[a]" + set chunk [textblock::join -- $displaycount$label " " $displayval[a]] } else { - puts $channel "$displaycount$label$displayval[a yellow bold]$more[a]" + #puts $channel "$displaycount$label$displayval[a yellow bold]$more[a]" + set chunk [textblock::join -- $displaycount$label " " "$displayval[a yellow bold]$more[a]"] } + puts $channel $chunk return $val } @@ -8024,7 +8026,7 @@ namespace eval punk { lappend cmdinfo [list ./ "?${I}glob${NI}?" "view/change dir, list dirs."] lappend cmdinfo [list ../ "?${I}path${NI}" "go up one dir, then to path if given"] lappend cmdinfo [list .// "?${I}glob${NI}?" "view/change dir, list dirs and files"] - lappend cmdinfo [list ./new "${I}subdir${NI}..." "make new dir or dirs and show status"] + lappend cmdinfo [list newdir "${I}subdir${NI}..." "make new dir or dirs and show status"] lappend cmdinfo [list fcat "${I}file ?file?...${NI}" "cat file(s)"] set t [textblock::class::table new -minwidth 80 -show_seps 0] foreach row $cmdinfo { @@ -8046,9 +8048,9 @@ namespace eval punk { set title "[a+ brightgreen] Namespace navigation: " set cmdinfo [list] lappend cmdinfo [list n/ "?${I}ns${NI}|${I}glob${NI}?" "view/change namespace\n (accepts ns path globs e.g **::*get* to match\n commands at any level )"] - lappend cmdinfo [list n// "?${I}ns${NI}|${I}glob${NI}?" "view/change namespace (with command listing)"] - lappend cmdinfo [list "nn/" "" "go up one namespace"] - lappend cmdinfo [list "n/new" "${I}ns${NI}" "make child namespace and switch to it"] + lappend cmdinfo [list n// "?${I}ns${NI}|${I}glob${NI}?" "view/change namespace (with command listing)"] + lappend cmdinfo [list "nn/" "" "go up one namespace"] + lappend cmdinfo [list "newns" "${I}ns${NI}" "make child namespace and switch to it"] set t [textblock::class::table new -minwidth 80 -show_seps 0] foreach row $cmdinfo { $t add_row $row @@ -8236,104 +8238,110 @@ namespace eval punk { lappend chunks [list stdout $text] } console - term - terminal { - set indent [string repeat " " [string length "WARNING: "]] - lappend cstring_tests [dict create\ - type "PM "\ - msg "UN"\ - f7 punk::ansi::controlstring_PM\ - f7prefix "7bit ESC ^ secret "\ - f7suffix "safe"\ - f8 punk::ansi::controlstring_PM8\ - f8prefix "8bit \\x9e secret "\ - f8suffix "safe"\ - ] - lappend cstring_tests [dict create\ - type SOS\ - msg "NOT"\ - f7 punk::ansi::controlstring_SOS\ - f7prefix "7bit ESC X string "\ - f7suffix " hidden"\ - f8 punk::ansi::controlstring_SOS8\ - f8prefix "8bit \\x98 string "\ - f8suffix " hidden"\ - ] - lappend cstring_tests [dict create\ - type APC\ - msg "NOT"\ - f7 punk::ansi::controlstring_APC\ - f7prefix "7bit ESC _ APPLICATION PROGRAM COMMAND "\ - f7suffix " hidden"\ - f8 punk::ansi::controlstring_APC8\ - f8prefix "8bit \\x9f APPLICATION PROGRAM COMMAND "\ - f8suffix " hidden"\ - ] + if {[catch {package require punk::console} result]} { + set text "Unable to load punk::console package - cannot test\n$result" + lappend chunks [list stdout $text] + } else { - foreach test $cstring_tests { - set m [[dict get $test f7] [dict get $test msg]] - set hidden_width_m [punk::console::test_char_width $m] - set m8 [[dict get $test f8] [dict get $test msg]] - set hidden_width_m8 [punk::console::test_char_width $m8] - if {$hidden_width_m != 0 || $hidden_width_m8 != 0} { - if {$hidden_width_m == 0} { - set d "[a+ green bold][dict get $test f7prefix][a red]${m}[a][a+ green bold][dict get $test f7suffix][a]" - } else { - set d "[a+ yellow bold][dict get $test f7prefix][a red]$m[a][a+ yellow bold][dict get $test f7suffix][a]" - } - if {$hidden_width_m8 == 0} { - set d8 "[a+ green ][dict get $test f8prefix][a red]$m8[a][a+ green][dict get $test f8suffix][a]" - } else { - set d8 "[a+ yellow bold][dict get $test f8prefix][a red]$m8[a][a+ yellow bold][dict get $test f8suffix][a]" + set indent [string repeat " " [string length "WARNING: "]] + lappend cstring_tests [dict create\ + type "PM "\ + msg "UN"\ + f7 punk::ansi::controlstring_PM\ + f7prefix "7bit ESC ^ secret "\ + f7suffix "safe"\ + f8 punk::ansi::controlstring_PM8\ + f8prefix "8bit \\x9e secret "\ + f8suffix "safe"\ + ] + lappend cstring_tests [dict create\ + type SOS\ + msg "NOT"\ + f7 punk::ansi::controlstring_SOS\ + f7prefix "7bit ESC X string "\ + f7suffix " hidden"\ + f8 punk::ansi::controlstring_SOS8\ + f8prefix "8bit \\x98 string "\ + f8suffix " hidden"\ + ] + lappend cstring_tests [dict create\ + type APC\ + msg "NOT"\ + f7 punk::ansi::controlstring_APC\ + f7prefix "7bit ESC _ APPLICATION PROGRAM COMMAND "\ + f7suffix " hidden"\ + f8 punk::ansi::controlstring_APC8\ + f8prefix "8bit \\x9f APPLICATION PROGRAM COMMAND "\ + f8suffix " hidden"\ + ] + + foreach test $cstring_tests { + set m [[dict get $test f7] [dict get $test msg]] + set hidden_width_m [punk::console::test_char_width $m] + set m8 [[dict get $test f8] [dict get $test msg]] + set hidden_width_m8 [punk::console::test_char_width $m8] + if {$hidden_width_m != 0 || $hidden_width_m8 != 0} { + if {$hidden_width_m == 0} { + set d "[a+ green bold][dict get $test f7prefix][a red]${m}[a][a+ green bold][dict get $test f7suffix][a]" + } else { + set d "[a+ yellow bold][dict get $test f7prefix][a red]$m[a][a+ yellow bold][dict get $test f7suffix][a]" + } + if {$hidden_width_m8 == 0} { + set d8 "[a+ green ][dict get $test f8prefix][a red]$m8[a][a+ green][dict get $test f8suffix][a]" + } else { + set d8 "[a+ yellow bold][dict get $test f8prefix][a red]$m8[a][a+ yellow bold][dict get $test f8suffix][a]" + } + append warningblock \n "WARNING: terminal doesn't hide all [dict get $test type] control strings: $d $d8" } - append warningblock \n "WARNING: terminal doesn't hide all [dict get $test type] control strings: $d $d8" } - } - if {![catch {punk::console::check::has_bug_legacysymbolwidth} result]} { - if {$result} { - append warningblock \n "WARNING: terminal has legacysymbolwidth bug - screen position for symbol reports 2 wide but displays 1 wide." - append warningblock \n $indent "Layout using 'legacy symbols for computing' affected." - append warningblock \n $indent "(e.g textblock frametype block2 unsupported)" - append warningblock \n $indent "This can cause extreme layout deformation when ANSI is present" - append warningblock \n $indent "In some cases unwanted spacing effects occur at a distance from the characters causing it" + if {![catch {punk::console::check::has_bug_legacysymbolwidth} result]} { + if {$result} { + append warningblock \n "WARNING: terminal has legacysymbolwidth bug - screen position for symbol reports 2 wide but displays 1 wide." + append warningblock \n $indent "Layout using 'legacy symbols for computing' affected." + append warningblock \n $indent "(e.g textblock frametype block2 unsupported)" + append warningblock \n $indent "This can cause extreme layout deformation when ANSI is present" + append warningblock \n $indent "In some cases unwanted spacing effects occur at a distance from the characters causing it" + } + } else { + append warningblock \n "WARNING: terminal unable to check for legacysymbolwidth bug. err:$result" } - } else { - append warningblock \n "WARNING: terminal unable to check for legacysymbolwidth bug. err:$result" - } - if {![catch {punk::console::check::has_bug_zwsp} result]} { - if {$result} { - append warningblock \n "WARNING: terminal has zero width space (\\u200b) bug - cursor position incremented when it shouldn't be." - append warningblock \n $indent "The zwsp may or may not be displayed. zwsp contributes to line length and wrapping point" + if {![catch {punk::console::check::has_bug_zwsp} result]} { + if {$result} { + append warningblock \n "WARNING: terminal has zero width space (\\u200b) bug - cursor position incremented when it shouldn't be." + append warningblock \n $indent "The zwsp may or may not be displayed. zwsp contributes to line length and wrapping point" + } + } else { + append warningblock \n "WARNING: terminal unable to check for zwsp bug. err:$result" } - } else { - append warningblock \n "WARNING: terminal unable to check for zwsp bug. err:$result" - } - set grapheme_support [punk::console::grapheme_cluster_support] - #mode, 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) - if {![dict size $grapheme_support] || [dict get $grapheme_support mode] eq "unsupported" } { - append warningblock \n "WARNING: terminal either doesn't support grapheme clusters, or doesn't report so via decmode 2027 query." - if {[dict size $grapheme_support] && [dict get $grapheme_support available]} { - append warningblock \n $indent "(but punk::console::grapheme_cluster_support has determined it is probably available)" - } - } else { - if {![dict get $grapheme_support available]} { - switch -- [dict get $grapheme_support mode] { - "unset" { - append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is off." - } - "permanently_unset" { - append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is permanently off." - } - "BAD_RESPONSE" { - append warningblock \n "WARNING: terminal doesn't seem to recognize decmode 2027 query. No grapheme cluster support." + set grapheme_support [punk::console::grapheme_cluster_support] + #mode, 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) + if {![dict size $grapheme_support] || [dict get $grapheme_support mode] eq "unsupported" } { + append warningblock \n "WARNING: terminal either doesn't support grapheme clusters, or doesn't report so via decmode 2027 query." + if {[dict size $grapheme_support] && [dict get $grapheme_support available]} { + append warningblock \n $indent "(but punk::console::grapheme_cluster_support has determined it is probably available)" + } + } else { + if {![dict get $grapheme_support available]} { + switch -- [dict get $grapheme_support mode] { + "unset" { + append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is off." + } + "permanently_unset" { + append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is permanently off." + } + "BAD_RESPONSE" { + append warningblock \n "WARNING: terminal doesn't seem to recognize decmode 2027 query. No grapheme cluster support." + } } } } - } - if {![string length $warningblock]} { - set text "No terminal warnings\n" - lappend chunks [list stdout $text] + if {![string length $warningblock]} { + set text "No terminal warnings\n" + lappend chunks [list stdout $text] + } } } topics - help { diff --git a/src/modules/punk/aliascore-999999.0a1.0.tm b/src/modules/punk/aliascore-999999.0a1.0.tm index 0adb4f39..766c7a61 100644 --- a/src/modules/punk/aliascore-999999.0a1.0.tm +++ b/src/modules/punk/aliascore-999999.0a1.0.tm @@ -108,7 +108,7 @@ tcl::namespace::eval punk::aliascore { # the aliascore::init will temporarily extend the exports list to do the import, and then reset the exports to how they were. set aliases [tcl::dict::create\ val ::punk::pipe::val\ - tstr ::punk::lib::tstr\ + tstr ::punk::args::lib::tstr\ list_as_lines ::punk::lib::list_as_lines\ lines_as_list ::punk::lib::lines_as_list\ linelist ::punk::lib::linelist\ @@ -116,7 +116,7 @@ tcl::namespace::eval punk::aliascore { pdict ::punk::lib::pdict\ plist {::punk::lib::pdict -roottype list}\ showlist {::punk::lib::showdict -roottype list}\ - rehash ::punk::rehash\ + rehash ::punk::auto_exec::rehash\ showdict ::punk::lib::showdict\ ansistrip ::punk::ansi::ansistrip\ stripansi ::punk::ansi::ansistrip\ @@ -228,7 +228,7 @@ tcl::namespace::eval punk::aliascore { } } if {!$opt_force && [llength $conflicts]} { - error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts" + error "punk::aliascore::init declined to create any aliases or imports because conflicts found. Use -force == 1 conflicts:\n [join $conflicts "\n "]" } set failed [list] diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index db3e36c2..7e8715eb 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -273,21 +273,68 @@ tcl::namespace::eval ::punk::args {} tcl::namespace::eval ::punk::args::helpers { variable PUNKARGS namespace export * - #proc B {} {return \x1b\[1m} ;#a+ bold - #proc N {} {return \x1b\[22m} ;#a+ normal - #proc I {} {return \x1b\[3m} ;#a+ italic - #proc NI {} {return \x1b\[23m} ;#a+ noitalic - proc I {} {punk::ansi::a+ italic} - proc B {} {punk::ansi::a+ bold} - proc N {} {punk::ansi::a+ normal} - proc NI {} {punk::ansi::a+ italic} + proc B {} {return \x1b\[1m} ;#a+ bold + proc N {} {return \x1b\[22m} ;#a+ normal + proc I {} {return \x1b\[3m} ;#a+ italic + proc NI {} {return \x1b\[23m} ;#a+ noitalic + #proc I {} {punk::ansi::a+ italic} + #proc B {} {punk::ansi::a+ bold} + #proc N {} {punk::ansi::a+ normal} + #proc NI {} {punk::ansi::a+ italic} lappend PUNKARGS [list { @id -id ::punk::args::helpers::example @cmd -name punk::args::helpers::example\ -summary\ {Display formatting for argdoc example text}\ -help\ - {Wrap } + {Wrap a block of text (e.g tcl code) in a box with optional syntax highlighting and title. + The text is processed with punk::lib::tstr to allow for command substitution and basic formatting, + but without any further dedenting (i.e it's assumed the text is already dedented appropriately + based on context). + The example function is intended for use in punk::args::define scripts to format example text in + the generated documentation, but it can be used in other contexts too. + + The box is a plain grey background with a lighter grey top and bottom border. + There are no side borders so the text can be copied without extra characters getting in the way, + These top and bottom bars are implemented using unicode block characters so the bars are still + visible when ANSI is stripped. + + ${[punk::args::helpers::example -title "[a+ term-yellow Term-blue] Example 1 [a]" { + #A sample of an example block of text with a garish title and some basic tcl syntax highlighting. + + proc test {args} { + puts "[a+ red]hello world[a]" + } + + }]} + + This was generated with code like the following in the punk::args::define script: + + ${[punk::args::helpers::example -syntax none -tstr 1 { + + ${[example -title "[a+ term-yellow Term-blue] Example 1 [a]" { + #A sample of an example block of text with a garish title and some basic tcl syntax highlighting. + + proc test {args} { + puts "[a+ red]hello world[a]" + } + + }]} + + }]} + + Here we eat our own dog food by nesting the example text within an ${[B]}example${[N]} call with -tstr 0 + to prevent the tstr processing of the text, and -syntax none to prevent the syntax highlighting. + This allows us to show the actual code used to generate ${[a+ term-yellow Term-blue]} Example 1 ${[a+ defaultbg][a]} above without having to use any + escaping backslashes etc that may show in the output. + + Note the slight indent of 2 characters on the left of the text in the example block. + This is intentional to show that the text is indented within the box, and as it's reasonably appealing + visually, explains why the -padright option defaults to padding with 2 chars on the right of the text. + + see also ${[B]}punk::args::lib::tstr${[N]} + + } @opts -padright -type integer -default 2 -help\ {Number of padding spaces to add on RHS of text block} @@ -295,9 +342,24 @@ tcl::namespace::eval ::punk::args::helpers { tcl\ " Very basic tcl syntax highlighting of braces,square brackets and comments." - -title -type string -default "" + } + -title -type string -default "" -help\ + {Optional title to display in the top border of the box. + The title is overlaid on the top bar which consists of lower-half block characters. + These block characters are set with foreground black and background silver, so the lower portion + of the bar appears silver. When the title is overlaid on top of this it gets the same colouring + so that the result is black text on siver background, but full height for the width of the title text. + + The title colour can be set to something other than the default black on silver by including ANSI in + the title text, but the bar on either side will still be silver. + e.g -title "[a+ term-yellow Term-blue]yellow on blue title[a]" + } + -tstr -type boolean -default 1 -help\ + {By setting this to false, we can disable tstr processing of the text. This means that the text will be + treated as a literal string and any tstr variable or command substitution will not be processed. + This can be useful if you want to include text that contains tstr formatting characters or commands + without them being interpreted.} -titlealign -type string -choices {left centre right} - } text -type string }] proc example {args} { @@ -317,10 +379,11 @@ tcl::namespace::eval ::punk::args::helpers { -syntax tcl\ -title ""\ -titlealign left\ + -tstr 1\ ] dict for {o v} $optlist { switch -- $o { - -padright - -syntax - -title - -titlealign {} + -padright - -syntax - -title - -titlealign - -notstr {} default { punk::args::parse $args withid ::punk::args::helpers::example return @@ -332,6 +395,7 @@ tcl::namespace::eval ::punk::args::helpers { set opt_syntax [dict get $opts -syntax] set opt_title [dict get $opts -title] set opt_titlealign [dict get $opts -titlealign] + set opt_tstr [dict get $opts -tstr] if {[string index $str 0] eq "\n"} { set str [string range $str 1 end] @@ -341,7 +405,10 @@ tcl::namespace::eval ::punk::args::helpers { } #example is intended to run from a source doc that has already been dedented appropriately based on context # - we don't want to further undent, hence -undent 0 - set str [uplevel 1 [list punk::lib::tstr -undent 0 -return string -eval 1 -allowcommands $str]] + if {$opt_tstr} { + #this is the default + set str [uplevel 1 [list punk::lib::tstr -undent 0 -return string -eval 1 -allowcommands $str]] + } #puts stderr ------------------- #puts $str #puts stderr ------------------- @@ -752,6 +819,10 @@ tcl::namespace::eval punk::args { argument name - only applies to final leader OR final value) (for options/flags this allows the opt-val pair or solo flag to appear multiple times - not necessarily contiguously) + -multipleunique (only valid if -multiple is true) + If true, when multiple values are stored against the same argument + name due to -multiple being true, the values must be unique. + If false, the same value can be stored multiple times. -choices {} A list of allowable values for an argument. The -default value doesn't have to be in the list. @@ -809,6 +880,24 @@ tcl::namespace::eval punk::args { If allows more than one choice the value is a list consisting of items in the choices made available through entries in -choices/-choicegroups. + -choicemultipleunique (default 0) + If choicemultiple is set to allow more than one choice, this + option specifies whether the choices must be unique within the + value list. If true, the same choice can't be selected more than + once. If false, the same choice can be selected multiple times. + -choicemultipleuniqueset (default 0) + Only applies if -choicemultiple is true and -multiple is true. + If choicemultiple is set to allow more than one choice, and + -multiple is true, this option specifies whether the sets of + choices must be unique across multiple occurrences of the argument. + If true, the same set of choices can't be selected more than once + across multiple occurrences of the multi-choice argument. + If false, the same set of choices can be selected multiple times + across multiple occurrences of the argument. + Without this option being set true, if -multiple is true and + -multipleunique is true, then the same set of choices in a + different order would be considered unique, which may not be + desirable. -unindentedfields {} for fields with multi-line values, tell the resolver to treat them as unindented. ie do no indent/unindent processing of @@ -902,8 +991,11 @@ tcl::namespace::eval punk::args { -choiceprefix 1\ -choicerestricted 1\ -choicemultiple {1 1}\ + -choicemultipleunique 0\ + -choicemultipleuniqueset 0\ -unindentedfields {}\ -multiple 0\ + -multipleunique 0\ -regexprepass {}\ -validationtransform {}\ -ensembleparameter 0\ @@ -918,8 +1010,11 @@ tcl::namespace::eval punk::args { -choiceprefix 1\ -choicerestricted 1\ -choicemultiple {1 1}\ + -choicemultipleunique 0\ + -choicemultipleuniqueset 0\ -unindentedfields {}\ -multiple 0\ + -multipleunique 0\ -regexprepass {}\ -validationtransform {}\ -prefix 1\ @@ -938,8 +1033,11 @@ tcl::namespace::eval punk::args { -choiceprefix 1\ -choicerestricted 1\ -choicemultiple {1 1}\ + -choicemultipleunique 0\ + -choicemultipleuniqueset 0\ -unindentedfields {}\ -multiple 0\ + -multipleunique 0\ -regexprepass {}\ -validationtransform {}\ ] @@ -1718,7 +1816,8 @@ tcl::namespace::eval punk::args { } -unindentedfields - -minsize - -maxsize - - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - + -choices - -choicegroups - -choicemultiple - + -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted { #review - only apply to certain types? tcl::dict::set tmp_optspec_defaults $k $v @@ -1807,7 +1906,8 @@ tcl::namespace::eval punk::args { -allow_ansi - -validate_ansistripped - -strip_ansi - - -multiple - + -multiple - -multipleunique - + -choicemultipleunique - -choicemultipleuniqueset - -prefix { #check is bool if {![string is boolean -strict $v]} { @@ -1823,6 +1923,7 @@ tcl::namespace::eval punk::args { -unindentedfields\ -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple -prefix\ + -multipleunique -choicemultipleunique -choicemultipleuniqueset\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ } error "punk::args::resolve - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" @@ -1936,7 +2037,10 @@ tcl::namespace::eval punk::args { -allow_ansi - -validate_ansistripped - -strip_ansi - - -multiple { + -multiple - + -multipleunique - + -choicemultipleunique - -choicemultipleuniqueset - + -optional { if {![string is boolean -strict $v]} { error "punk::args::resolve - invalid type of value '$v' for key '$k' in @leaders line. Must be boolean @id:$DEF_definition_id" } @@ -1961,6 +2065,7 @@ tcl::namespace::eval punk::args { -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ -unindentedfields\ -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -multipleunique -choicemultipleunique -choicemultipleuniqueset\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ -unnamed\ } @@ -2051,11 +2156,13 @@ tcl::namespace::eval punk::args { -typeranges { tcl::dict::set tmp_valspec_defaults -typeranges $v } - -optional - -allow_ansi - -validate_ansistripped - -strip_ansi - - -multiple { + -multiple - + -multipleunique - + -choicemultipleunique - -choicemultipleuniqueset - + -optional { if {![string is boolean -strict $v]} { error "punk::args::resolve - invalid type of value '$v' for key '$k' in @values line. Must be boolean @id:$DEF_definition_id" } @@ -2083,6 +2190,7 @@ tcl::namespace::eval punk::args { -unindentedfields\ -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -multipleunique -choicemultipleunique -choicemultipleuniqueset\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ -unnamed\ } @@ -2414,6 +2522,7 @@ tcl::namespace::eval punk::args { -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted - -choicelabels - -choiceinfo - -minsize - -maxsize - -nocase - -multiple - + -multipleunique - -choicemultipleunique - -choicemultipleuniqueset - -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - -regexprepass - -regexprefail - -regexprefailmsg { @@ -2519,6 +2628,7 @@ tcl::namespace::eval punk::args { -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted\ -unindentedfields\ -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -multipleunique -choicemultipleunique -choicemultipleuniqueset\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ -ensembleparameter\ ] @@ -9228,7 +9338,7 @@ tcl::namespace::eval punk::args { set v_test $c_check } set choice_in_list 0 - set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? + set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval could be a list when -choicemultiple? if {!$matches_default} { if {$choiceprefix} { #can we handle empty string as a choice? It should just work - REVIEW/test @@ -9277,6 +9387,7 @@ tcl::namespace::eval punk::args { set chosen $bestmatch set choice_in_list 1 } + puts ">>>>> chosen: $chosen bestmatch: $bestmatch for c_check: $c_check choices_test: $choices_test allchoices: $allchoices" } else { set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check] if {$chosen eq "" || $chosen in $choiceprefixreservelist} { @@ -9302,9 +9413,11 @@ tcl::namespace::eval punk::args { if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { #single choice allowed per clause-member if {$is_multiple} { + puts ">>>>> existing:'$existing' element_index:$element_index choice_index:$choice_idx chosen: $chosen" if {$clause_size == 1} { #no list wrapping of single element in $dname dict - so don't index into it with element_index - lset existing $element_index $chosen + #lset existing $element_index $chosen ;#wrong - test::punk::args test: choice_multiple_with_choiceprefix. + lset existing $clause_index $chosen } else { lset existing $clause_index $element_index $chosen } @@ -10626,10 +10739,29 @@ tcl::namespace::eval punk::args::lib { Placeholder Substitutions: \$\{$varName\} \$\{[myCommand]\} - (when -allowcommands flag is given)" + (myCommand is evaluated when -allowcommands flag is given) + + If any error occurs during placeholder evaluation, the original placeholder text + is substituted in the output and the error is included in the returned dict + (if -return dict is used). + " -allowcommands -default 0 -type none -help\ - "If -allowcommands is present, placeholder can contain commands - e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" + "If -allowcommands is present, placeholder commands are evaluated and subtituted. + e.g tstr -allowcommands { \$\{plaintext0 [lindex $var 1] plaintext2\} } + + if $var is {a b c}, the result will be \"plaintext0 b plaintext2 \" + if $var does not exist the result will be \"\$\{plaintext0 [lindex $var 1] plaintext2\} \" + with an error recorded in the returned dict if -return dict is used. + + NOTE: even if -allowcommands is not present, the placeholder text is still processed for variable + substitution and escape sequence processing, so the result will not be the raw placeholder text. + The result will be \"plaintext0 [lindex {a b c} 0] plaintext2 \" + + e.g + tstr -undent 0 -allowcommands { \$\{ \\$var\\[1\\] = [lindex $var 1]\}} + $var[1] = b + " + -undent -default 1 -type boolean -help\ "undent/dedent the template lines. The longest common prefix of whitespace is removed" @@ -10702,6 +10834,14 @@ tcl::namespace::eval punk::args::lib { which expects the placeholders as individual arguments" } + -raise_errors -default 0 -type boolean -help\ + "By default, if an error occurs during placeholder evaluation, the original placeholder text + is substituted in the output and the error is included in the returned dict (if -return dict is used). + If -raise_errors is set to 1, the template will be processed and a list of errors will be collected as + normal, but if any errors are present at the end of processing, a single error will be raised with a + summary of all errors that occurred. + This can be useful for debugging or when you want to ensure that any issues with placeholder evaluation + are immediately visible and not silently included in the output." -eval -default 1 -type boolean -help\ "Whether to evaluate the \$\{\} placeholders. When -return is string, -eval should generally be set to 1. @@ -10739,6 +10879,7 @@ tcl::namespace::eval punk::args::lib { -paramindents line\ -eval 1\ -return string\ + -raise_errors 0\ ] if {"-allowcommands" in $arglist} { set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] @@ -10754,9 +10895,9 @@ tcl::namespace::eval punk::args::lib { } } dict for {k v} $arglist { - set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] + set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval -raise_errors} $k] switch -- $fullk { - -indent - -undent - -paramindents - -return - -eval { + -indent - -undent - -paramindents - -return - -eval - -raise_errors { dict set opts $fullk $v } default { @@ -10781,6 +10922,7 @@ tcl::namespace::eval punk::args::lib { set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] if {$opt_return eq ""} { } + set opt_raise_errors [dict get $opts -raise_errors] set opt_eval [dict get $opts -eval] @@ -10871,6 +11013,14 @@ tcl::namespace::eval punk::args::lib { incr idx ;#expression incr } + if {$opt_raise_errors && [dict size $errors]} { + set einfo "" + dict for {i e} $errors { + append einfo "parameter $i error: $e" \n + } + error "punk::args::lib::tstr: Errors occurred during placeholder evaluation:\n$einfo" + } + if {$opt_return eq "dict"} { return [dict create template $textchunks params $params errors $errors] } @@ -11200,17 +11350,39 @@ tcl::namespace::eval punk::args::package { set pkgname [${pkgns}::package_name] set opt_return [dict get $OPTS -return] - set all_topics [${pkgns}::about_topics] + set defined_topics [${pkgns}::about_topics] if {![dict exists $received topic]} { - set topics $all_topics + set topics $defined_topics } else { # * represents all remaining topics not explicitly mentioned. set val_topics [dict get $values topic] ;#if -multiple is true, this is a list - set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] + #set explicit_topic_prefixes [lsearch -all -inline -exact -not $val_topics "*"] + set explicit_topics [list] + set requested_topics [list] + set defined_topics_lc [lmap t $defined_topics {string tolower $t}] + foreach et $val_topics { + #topics are case insensitive. We don't expect function names from about_topics to have variations differing only in case. + #todo - enforce this by only returning the last value from about_topics for each particular topic when there are duplicates differing only in case. + #(see punk::auto_execs for example. TODO -add to template or use helper function to enforce this when processing about_topics) + if {$et eq "*"} { + lappend requested_topics "*" + continue + } + + set fulltopic_lc [tcl::prefix::match -error "" $defined_topics_lc [string tolower $et]] + if {$fulltopic_lc eq ""} { + error "punk::args::package::standard_about topic '$et' does not match any defined topics: $defined_topics" + } else { + set resolved_topic [lsearch -inline -nocase $defined_topics $fulltopic_lc] + lappend explicit_topics $resolved_topic + lappend requested_topics $resolved_topic + } + } + set topics [list] - foreach t $val_topics { + foreach t $requested_topics { if {$t eq "*"} { - foreach a $all_topics { + foreach a $defined_topics { if {$a ni $explicit_topics} { lappend topics $a } diff --git a/src/modules/punk/auto_exec-999999.0a1.0.tm b/src/modules/punk/auto_exec-999999.0a1.0.tm index 0b0ca696..e629128b 100644 --- a/src/modules/punk/auto_exec-999999.0a1.0.tm +++ b/src/modules/punk/auto_exec-999999.0a1.0.tm @@ -47,6 +47,45 @@ tcl::namespace::eval punk::auto_exec { set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline] } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id "::punk::auto_exec::rehash" + @cmd -name "punk::auto_exec::rehash"\ + -summary\ + "Update the hash table of autoexec commands cached in ::auto_execs."\ + -help\ + {Clear/refresh the autoexec commands in the ::auto_execs array. + + This is analogous to the 'rehash' command in shells such as csh, tcsh and zsh. + It updates the shell's hash table of executable commands. + + This can be useful after installing new software, adjusting the environment PATH directories, or (on windows) making + changes to the system that may affect file type associations and their associated commands, to ensure that the autoexec + commands are up to date with the current state of the system. + + If refresh is false (the default), then all autoexec commands are cleared and will re-register as commands are called. + If refresh is true, then all existing autoexec commands are re-registered by calling auto_execok for each of them again.} + @opts + @values -min 0 -max 1 + refresh -type boolean -default 0 -help\ + "Whether to re-register existing autoexec commands by calling auto_execok for each of them again." + }] + } + proc rehash {{refresh 0}} { + global auto_execs + if {!$refresh} { + unset -nocomplain auto_execs + } else { + set names [array names auto_execs] + unset -nocomplain auto_execs + foreach nm $names { + #auto_execok_windows $nm + auto_execok $nm + } + } + return + } + variable PUNKARGS lappend PUNKARGS [list { @id -id "::punk::auto_exec::shell_open_command" @@ -347,7 +386,7 @@ tcl::namespace::eval punk::auto_exec { if {!$new_chunk} { if {$current_chunk ne "" || $current_chunk eq "" && [lindex $quoted end]} { - #we add the current chunk to the result list if it's not empty, or if it is empty but is quoted (because in that case we want to preserve it as an empty argument). + #we add the current chunk to the result list if it's not empty, or if it is empty but is quoted (because in that case we want to preserve it as an empty argument). lappend result $current_chunk lappend quoted 0 set current_chunk {} @@ -564,15 +603,17 @@ tcl::namespace::eval punk::auto_exec { user-specific association is found. Returns a dict of dicts with toplevel keys for each shell verb (e.g open, runas) and values that are dicts with keys - ${$I}type${$NI} and ${$I}value${$NI} and ${$I}scope${$NI}, where - type is determined from the registry value type (e.g sz or expand_sz) - string is the raw command string from the registry - scope is either "user" or "system" depending on whether the value was found in the user-specific registry keys or - the system registry keys. + ${$I}type${$NI} and ${$I}value${$NI} and ${$I}scope${$NI}, where: + + ${$I}type${$NI} is determined from the registry value type (e.g sz or expand_sz) + + ${$I}string${$NI} is the raw command string from the registry + + ${$I}scope${$NI} is either \"user\" or \"system\" depending on whether the value was found in the user-specific + registry keys or the system registry keys. This is somewhat like the windows 'ftype' command except that the windows command only looks for the 'open' verb and - only looks up the system association and does not take into account any user-specific - overrides. + only looks up the system association and does not take into account any user-specific overrides. The file type can be looked up using the ${$B}assoc${$N} function in this package. @@ -587,40 +628,11 @@ tcl::namespace::eval punk::auto_exec { This can be looked up using the 'assoc' function in this package." }] } - #proc ftype {filetype} { - # package require registry - - # if {$filetype eq "cplfile"} { - # #special case for cplfile (associated with .cpl files) which doesn't follow the usual pattern of having the command string under shell\open\command, - # #but instead has it under HKEY_LOCAL_MACHINE\SOFTWARE\Classes\cplfile\shell\cplopen\command. - # #There doesn't seem to be any user-specific override for this file type - # #- but we will check for one under HKEY_CURRENT_USER\Software\Classes\cplfile\shell\cplopen\command anyway for consistency with the way we check - # #for user-specific overrides for other file types. - # set key [join [list HKEY_CURRENT_USER Software Classes cplfile shell cplopen command] "\\"] - # } else { - # set key [join [list HKEY_CURRENT_USER Software Classes $filetype shell open command] "\\"] - # } - # if {![catch {registry get $key ""} raw_assoc]} { - # set tp [registry type $key ""] - # return [dict create open [dict create type $tp string $raw_assoc]] - # } else { - # #e.g Python.File - # if {$filetype eq "cplfile"} { - # set key [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes cplfile shell cplopen command] "\\"] - # } else { - # set key [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $filetype shell open command] "\\"] - # } - # if {![catch {registry get $key ""} raw_assoc]} { - # set tp [registry type $key ""] - # return [dict create type $tp string $raw_assoc] - # } else { - # return [dict create type "" string ""] ;#no association found - # } - # } - #} proc ftype {filetype} { package require registry set resultdict [dict create] + #registry queries are case insensitive but some are keys are cased differently e.g Open vs open. + #when using the verb as a key in the output dict, we need to normalize so that it is useful for lookups. We'll use lowercase for that. #e.g Python.File set shellpath [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $filetype shell] "\\"] @@ -628,8 +640,6 @@ tcl::namespace::eval punk::auto_exec { foreach verb $shellverbs { set commandkey [join [list $shellpath $verb command] "\\"] if {![catch {registry get $commandkey ""} cmdstring]} { - #registry queryies are case insensitive but some are cased differently e.g Open vs open. - #when using the verb as a key in the output dict, we need to normalize so that it is useful for lookups. We'll use lowercase for that. set verb [string tolower $verb] set tp [registry type $commandkey ""] dict set resultdict $verb [dict create type $tp value $cmdstring scope system] @@ -649,7 +659,6 @@ tcl::namespace::eval punk::auto_exec { } } } - return $resultdict } @@ -671,9 +680,9 @@ tcl::namespace::eval punk::auto_exec::lib { #} -# == === === === === === === === === === === === === === === +# == === === === === === === === === === === === === === === # Sample 'about' function with punk::args documentation -# == === === === === === === === === === === === === === === +# == === === === === === === === === === === === === === === tcl::namespace::eval punk::auto_exec { tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase variable PUNKARGS @@ -682,8 +691,7 @@ tcl::namespace::eval punk::auto_exec { lappend PUNKARGS [list { @id -id "(package)punk::auto_exec" @package -name "punk::auto_exec" -help\ - "Package - Description" + "An autoexec_ok replacement for Tcl with support for windows file type associations and command string parsing." }] namespace eval argdoc { @@ -695,26 +703,34 @@ tcl::namespace::eval punk::auto_exec { #info commands results are returned in an arbitrary order (like array keys) set topic_funs [info commands [namespace current]::get_topic_*] set about_topics [list] + #use a dict to enforce last case-variation of a topic wins. + set case_dict [dict create] foreach f $topic_funs { set tail [namespace tail $f] - lappend about_topics [string range $tail [string length get_topic_] end] + set t [string range $tail [string length get_topic_] end] + set t_lc [string tolower $tail] + dict set case_dict $t_lc $t + } + dict for {lc t} $case_dict { + lappend about_topics $t } + #Adjust this function or 'default_topics' if a different order is required return [lsort $about_topics] } proc default_topics {} {return [list Description *]} # ------------------------------------------------------------- - # get_topic_ functions add more to auto-include in about topics + # get_topic_ functions add more to auto-include in about topics # ------------------------------------------------------------- proc get_topic_Description {} { - punk::args::lib::tstr [string trim { - package punk::auto_exec - description to come.. + punk::args::lib::tstr [string trim { + package punk::auto_exec + A replacement for Tcl's builtin autoexec_ok function. } \n] } proc get_topic_License {} { - return "" + return "BSD-3-Clause" } proc get_topic_Version {} { return "$::punk::auto_exec::version" @@ -730,22 +746,41 @@ tcl::namespace::eval punk::auto_exec { } return $contributors } - proc get_topic_custom-topic {} { - punk::args::lib::tstr -return string { - A custom - topic - etc - } + proc get_topic_Notes {} { + return [string trim { + This package primarily provides advanced features on the windows platform, but some functions such as 'rehash' are + useful on any platform. + + This package provides functions to look up windows file type associations and to parse command strings with placeholders + and environment variables, which can be used as a replacement for Tcl's autoexec_ok function in certain contexts. + + The 'assoc' function looks up the associated file type for a given file extension, taking into account both user-specific + and system-wide associations in the registry. + + The 'ftype' function looks up the shell verb command values for a given file type, also taking into account both user-specific + and system-wide associations in the registry. + + The 'shell_command_as_tcl_list' function processes a command string with placeholders and environment variables and returns a + Tcl list of command and arguments with the placeholders substituted according to the specified rules. + + } \n] } + #proc get_topic_custom-topic {} { + # punk::args::lib::tstr -return string { + # A custom + # topic + # etc + # } + #} # ------------------------------------------------------------- } # we re-use the argument definition from punk::args::standard_about and override some items set overrides [dict create] dict set overrides @id -id "::punk::auto_exec::about" - dict set overrides @cmd -name "punk::auto_exec::about" + dict set overrides @cmd -name "punk::auto_exec::about" dict set overrides @cmd -help [string trim [punk::args::lib::tstr { - About punk::auto_exec + About punk::auto_exec }] \n] dict set overrides topic -choices [list {*}[punk::auto_exec::argdoc::about_topics] *] dict set overrides topic -choicerestricted 1 @@ -761,7 +796,7 @@ tcl::namespace::eval punk::auto_exec { } } # end of sample 'about' function -# == === === === === === === === === === === === === === === +# == === === === === === === === === === === === === === === # ----------------------------------------------------------------------------- @@ -776,11 +811,11 @@ namespace eval ::punk::args::register { # ----------------------------------------------------------------------------- # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::auto_exec [tcl::namespace::eval punk::auto_exec { variable pkg punk::auto_exec variable version - set version 999999.0a1.0 + set version 999999.0a1.0 }] return diff --git a/src/modules/punk/config-0.1.tm b/src/modules/punk/config-0.1.tm index 8d5a5dca..3d967541 100644 --- a/src/modules/punk/config-0.1.tm +++ b/src/modules/punk/config-0.1.tm @@ -15,13 +15,16 @@ tcl::namespace::eval punk::config { namespace eval punk {namespace export config} proc _homedir {} { - if {[info exists ::env(HOME)]} { - set home [file normalize $::env(HOME)] - } else { - #not available on 8.6? ok will error out here. - set home [file tildeexpand ~] - } - return $home + return [punk::nav::fs::~] ;#will work if HOME is not set. + #may return an error if no home directory can be determined + + #if {[info exists ::env(HOME)]} { + # set home [file normalize $::env(HOME)] + #} else { + # #not available on 8.6? ok will error out here. + # set home [file tildeexpand ~] + #} + #return $home } lappend PUNKARGS [list { diff --git a/src/modules/punk/du-999999.0a1.0.tm b/src/modules/punk/du-999999.0a1.0.tm index 9ea38214..71aa9090 100644 --- a/src/modules/punk/du-999999.0a1.0.tm +++ b/src/modules/punk/du-999999.0a1.0.tm @@ -1712,7 +1712,7 @@ namespace eval punk::du { set errors [dict create] foreach {k v} $args { switch -- $k { - -glob - -with_sizes - -with_times { + -glob - -filedebug - -patterndebug - -link_info - -with_sizes - -with_times - -types { dict set opts $k $v } default { @@ -1766,6 +1766,7 @@ namespace eval punk::du { set types_entry [list] set types_attribute [list] set types_permission [list] + set types_REQUIRED [list] foreach t $entry_and_attribute_types { switch -- $t { f - d - l - p - s - b - c { @@ -1775,16 +1776,46 @@ namespace eval punk::du { hidden - readonly { #these are all valid attributes lappend types_attribute $t + lappend types_REQUIRED $t } r - w - x { #these are all valid permissions lappend types_permission $t + lappend types_REQUIRED $t } default { error "du_dirlisting_generic unrecognized element in -types '$t'. Known types/attributes/permissions: f d l p s b c hidden readonly r w x" } } } + + set do_sizes_d [expr {"d" in $sized_types}] + set do_sizes_f [expr {"f" in $sized_types}] + set do_sizes_l [expr {"l" in $sized_types}] + set do_times_d [expr {"d" in $timed_types}] + set do_times_f [expr {"f" in $timed_types}] + set do_times_l [expr {"l" in $timed_types}] + if {[llength $types_entry] && "d" ni $types_entry} { + set skip_dirs 1 + } else { + set skip_dirs 0 + } + if {[llength $types_entry] && "f" ni $types_entry} { + set skip_files 1 + } else { + set skip_files 0 + } + if {[llength $types_entry] && "l" ni $types_entry} { + set skip_links 1 + } else { + set skip_links 0 + } + set trequire_hidden [expr {"hidden" in $types_REQUIRED}] + set trequire_readonly [expr {"readonly" in $types_REQUIRED}] + set trequire_executable [expr {"x" in $types_REQUIRED}] + set trequire_readable [expr {"r" in $types_REQUIRED}] + set trequire_writable [expr {"w" in $types_REQUIRED}] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- # The repeated globs are a source of slowness for this function. @@ -1813,56 +1844,42 @@ namespace eval punk::du { if {$opt_glob eq "*"} { #Note - multiple glob operations with restrictions seem to be faster than looped tests like 'file isdirectory' & 'file readlink' #set parent [lindex $folders $folderidx] - if {![llength $types_entry] || "d" in $types_entry} { - #we need to check directories for hidden attribute - as on windows, not all dotfiles are hidden, and not all hidden files are dotfiles - set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} * .*] - set dirs [glob -nocomplain -dir $folderpath -types d * .*] - } - if {![llength $types_entry] || "l" in $types_entry} { - set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} * .*] - set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique - } - if {![llength $types_entry] || "f" in $types_entry} { - set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} * .*] - set files [glob -nocomplain -dir $folderpath -types f * .*] - } + set globs [list *] } else { - if {![llength $types_entry] || "d" in $types_entry} { - #we need to check directories for hidden attribute - as on windows, not all dotfiles are hidden, and not all hidden files are dotfiles - set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} $opt_glob] - set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] - } - if {![llength $types_entry] || "l" in $types_entry} { - set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} $opt_glob] - set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique - } - if {![llength $types_entry] || "f" in $types_entry} { - set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} $opt_glob] - set files [glob -nocomplain -dir $folderpath -types f $opt_glob] - } + set globs [list $opt_glob] + } + #on windows this is a lot of separate globs to perform. Using the du_dirlisting_twapi is preferred for performance on windows - but this is a fallback and for testing. + #if {![llength $types_entry] || "d" in $types_entry} {} + if {!$skip_dirs} { + #we need to check directories for hidden attribute - as on windows, not all dotfiles are hidden, and not all hidden files are dotfiles + set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} {*}$globs] + set dirs [glob -nocomplain -dir $folderpath -types d {*}$globs] + } + if {!$skip_links} { + set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} {*}$globs] + set links [glob -nocomplain -dir $folderpath -types l {*}$globs] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique + } + if {!$skip_files} { + set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} {*}$globs] + set files [glob -nocomplain -dir $folderpath -types f {*}$globs] } } else { if {$opt_glob eq "*"} { - #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink' - #set parent [lindex $folders $folderidx] - #set dirs [glob -nocomplain -dir $folderpath -types d * .*] - #set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique - #set files [glob -nocomplain -dir $folderpath -types f * .*] set globs [list * .*] } else { set globs [list $opt_glob] - #set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] - #set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique - #set files [glob -nocomplain -dir $folderpath -types f $opt_glob] } - - if {![llength $types_entry] || "d" in $types_entry} { + #we need to classify our results - unlike a standard glob * operation which returns all entries in one collection. + #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink' + #however - these are still significantly slower than a single glob with no restrictions - so we want to minimize the number of globs we do + #- but we also want to avoid doing extra work classifying entries that we will end up ignoring based on types/attributes/permissions filters. + if {!$skip_dirs} { set dirs [glob -nocomplain -dir $folderpath -types d {*}$globs] } - if {![llength $types_entry] || "l" in $types_entry} { + if {!$skip_links} { set links [glob -nocomplain -dir $folderpath -types l {*}$globs] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique } - if {![llength $types_entry] || "f" in $types_entry} { + if {!$skip_files} { set files [glob -nocomplain -dir $folderpath -types f {*}$globs] } @@ -1957,6 +1974,7 @@ namespace eval punk::du { set types_entry [list] set types_attribute [list] set types_permission [list] + set types_REQUIRED [list] foreach t $entry_and_attribute_types { switch -- $t { f - d - l - p - s - b - c { @@ -2155,7 +2173,7 @@ namespace eval punk::du { set errors [dict create] if {"windows" eq $::tcl_platform(platform)} { if {$opt_glob eq "*"} { - set globs [list * .*] + set globs [list *] } else { set globs [list $opt_glob] } @@ -2295,6 +2313,13 @@ namespace eval punk::du { #we don't classify anything as 'flaggedhidden' on unix. #it is a convention for dotfiles rather than a flag - and we'll leave the distinction for the display library + set dirs {} + set hdirs {} + set files {} + set hfiles {} + set links {} + set hlinks {} + if {$opt_glob eq "*"} { set globs [list * .*] } else { @@ -2341,6 +2366,7 @@ namespace eval punk::du { if {"$ft" in $meta_types} { foreach path [set $lvar] { if {$has_winpath && [punk::winpath::illegalname_test $path]} { + #review. we don't want to fix the path - we just want classify it as nonportable set testpath [punk::winpath::illegalname_fix $path] if {![catch {file stat $testpath arrstat} errM]} { dict set meta_dict $path [dict create shorttype $ft {*}[array get arrstat]] @@ -2350,7 +2376,7 @@ namespace eval punk::du { dict set meta_dict $path [dict create shorttype $ft {*}$empty_stat_dict] } } else { - #caller may have read perm on the containing folder - but not on child item - so file stat could raise an error + #caller may have permission to read on the containing folder - but not on child item - so file stat could raise an error if {![catch {file stat $path arrstat} errM]} { dict set meta_dict $path [dict create shorttype $ft {*}[array get arrstat]] } else { @@ -2463,28 +2489,38 @@ namespace eval punk::du { } proc du_dirlisting_undecided {folderpath args} { - if {"windows" eq $::tcl_platform(platform)} { - #jmn disable twapi - #tailcall du_dirlisting_generic $folderpath {*}$args - - package require zzzload - set loadstate [zzzload::pkg_require twapi] - if {$loadstate ni [list loading failed]} { - #either already loaded by zzload or ordinary package require - package require twapi ;#should be fast once twapi dll loaded in zzzload thread - set ::punk::du::has_twapi 1 - punk::du::active::set_active_function du_dirlisting du_dirlisting_twapi - tailcall du_dirlisting_twapi $folderpath {*}$args - } else { - if {$loadstate eq "failed"} { - puts stderr "punk::du defaulting to du_dirlisting_generic because twapi load failed" - punk::du::active::set_active_function du_dirlisting du_dirlisting_generic + switch -- $::tcl_platform(platform) { + windows { + #jmn disable twapi + #tailcall du_dirlisting_generic $folderpath {*}$args + + package require zzzload + set loadstate [zzzload::pkg_require twapi] + + if {$loadstate ni [list loading failed]} { + #either already loaded by zzload or ordinary package require + package require twapi ;#should be fast once twapi dll loaded in zzzload thread + set ::punk::du::has_twapi 1 + punk::du::active::set_active_function du_dirlisting du_dirlisting_twapi + tailcall du_dirlisting_twapi $folderpath {*}$args + } else { + if {$loadstate eq "failed"} { + puts stderr "punk::du defaulting to du_dirlisting_generic because twapi load failed" + punk::du::active::set_active_function du_dirlisting du_dirlisting_generic + } + tailcall du_dirlisting_generic $folderpath {*}$args } - tailcall du_dirlisting_generic $folderpath {*}$args } - } else { - punk::du::active::set_active_function du_dirlisting du_dirlisting_unix - tailcall du_dirlisting_unix $folderpath {*}$args + default { + #todo - macOS specific optimizations? e.g using macos metadata to determine hidden/readonly/system flags etc? + #macOS uses a case-insensitive filesystem by default like windows. + + #punk::du::active::set_active_function du_dirlisting du_dirlisting_unix + #tailcall du_dirlisting_unix $folderpath {*}$args + + punk::du::active::set_active_function du_dirlisting du_dirlisting_generic + tailcall du_dirlisting_generic $folderpath {*}$args + } } } diff --git a/src/modules/punk/mix/util-999999.0a1.0.tm b/src/modules/punk/mix/util-999999.0a1.0.tm index 78a8568b..e78b6df6 100644 --- a/src/modules/punk/mix/util-999999.0a1.0.tm +++ b/src/modules/punk/mix/util-999999.0a1.0.tm @@ -127,9 +127,14 @@ namespace eval punk::mix::util { foreach p $finalpaths { if {$has_winlnk && [file extension $p] eq ".lnk"} { set resolve_info [punk::winlnk::resolve $p] - set resolved [dict get $resolve_info link_target] + set resolved [dict get $resolve_info link_roottarget] if {$resolved ne ""} { - lappend resolved_finalpaths $resolved + if {[dict exists $resolve_info stringdata command_line_arguments]} { + puts stderr "link $p has arguments. Will cat the .lnk file itself rather than the root target." + lappend resolved_finalpaths $p + } else { + lappend resolved_finalpaths $resolved + } } else { lappend resolved_finalpaths $p } diff --git a/src/modules/punk/nav/fs-999999.0a1.0.tm b/src/modules/punk/nav/fs-999999.0a1.0.tm index 24c90818..78098df7 100644 --- a/src/modules/punk/nav/fs-999999.0a1.0.tm +++ b/src/modules/punk/nav/fs-999999.0a1.0.tm @@ -157,6 +157,177 @@ tcl::namespace::eval punk::nav::fs { #[list_begin definitions] + #only lookup user_home once per interp or process + #It can be slightly expensive (for example involving network calls on windows domains) + variable user_home_cache + set user_home_cache "" + + #tilde + #These aliases work fine for interactive use - but the result is always a string internal-rep + #interp alias {} ~ {} file join $::env(HOME) ;#HOME must be capitalized to work cross platform (lowercase home works on windows - but probably not elsewhere) + #interp alias {} ~ {} apply {args {file join $::env(HOME) $args}} + namespace eval argdoc { + punk::args::define { + @id -id ::punk::nav::fs::~ + @cmd -name "punk::nav::fs::~"\ + -summary\ + "Return user's home directory as the process sees it"\ + -help\ + "Return the user's home directory path as the process sees it. + + (This is not always the same as ::env(HOME)) + + With additional arguments, return the path obtained by joining + the user's home directory with the supplied arguments. + + usage e.g + cd [~] + (change to user's home) + .// [~] .config + (change to .config directory within the user's home + and list contents.) + equivalently: + gohome .config + (gohome uses the output of ~ to determine the home directory) + + If the home directory cannot be determined due to the environment + in which the process is running, an error will be raised, as returning + an empty string is not a useful result and can cause issues if used as a path. + " + @opts + @values -min 0 -max -1 + arg -type any -optional 1 -multiple 1 + } + } + proc ~ {args} { + #review - HOME may be undefined or have been set to another value by other tools or the parent process. + #The process may even be running in a context where there is no home directory - e.g a container with no users, or a system service context. + #(we may be in a safe interp - which generally won't have env vars or filesystem access) + variable user_home_cache + if {$user_home_cache ne ""} { + set hdir $user_home_cache + #we still need to process args to join them to the home directory - but we can skip all the work of determining the home directory again. + } else { + set hdir "" + + if {[catch {auto_execok whoami} whoami_exe]} { + set whoami_exe "" + } + if {$whoami_exe eq ""} { + #try env USER or USERNAME - these are commonly set to the username on many platforms - but may not be set in all contexts. + if {[info exists ::env(USER)]} { + set user $::env(USER) + } elseif {[info exists ::env(USERNAME)]} { + set user $::env(USERNAME) + } else { + set user "" + } + } else { + #set user [exec {*}$whoami_exe] + if {[catch {exec {*}$whoami_exe} user]} { + set user "" + } + } + if {[string trim $user] ne ""} { + #normalize user for use with 'file tildeexpand ~' + #on windows, whoami may return DOMAIN\USER + #for tildeexpand to work, we need to convert this to USER@DOMAIN + if {"windows" eq $::tcl_platform(platform)} { + set parts [split $user "\\"] + #we expect only 1 or 2 parts + if {[llength $parts] == 2} { + lassign $parts domain username + + #if we use username@domain format - we get the domain controller's view of our home directory - which can be different from the local machine's view of our home directory. + #e.g file tildeexpand ~jnoble@corp can return a local non existant path like c:/users/jnoble + #but it may be c:/users/jnoble.corp - or c:/users/something_else_entirely depending on how the local machine is configured. + #It may be that the domain controller is correct if it returns a network path like \\server\users\jnoble ?? + #Network paths are not necessarily the preferred practive as of 2026 - but may still exist. + #Microsoft is encouraging the use of cloud systems - but it it unknown at this stage what sort of paths can be returned. + + #REVIEW + + set domainuser "$username@$domain" + #we can run file tildeexpand with username@domain and test if the path is writable + #this reduces the possibility that there happens to be a local user with the same name as the domain user - which would cause us to get the wrong home directory. + if {![catch {file tildeexpand ~$domainuser} path]} { + if {[file writable $path]} { + set user $domainuser + set hdir $path ;#set hdir so we don't re-lookup below. + } + } + if {$hdir eq ""} { + #for now we will use the unqualified username. + set user $username + } + + } elseif {[llength $parts] == 1} { + set user [lindex $parts 0] + } else { + #unexpected format - emit warning + puts stderr "Warning: Unexpected format of username '$user' returned by whoami. Expected format 'DOMAIN\\USER' or 'USER'. Unable to determine home directory for this user." + set user "" + } + } + + #only enter this branch if hdir wasn't resolved above for windows domain user. + if {$hdir eq "" && $user ne ""} { + #we use file tildeexpand ~user because the intention is stated in the tcl source as: + #* the intent is to retrieve (as on Unix) the system's view + #* of the home irrespective of environment settings of HOME + #* and USERPROFILE. + # - this aligns with our intention here. + if {![catch {file tildeexpand ~$user} path]} { + set hdir [punk::valcopy $path] + } else { + #tcl <= 8.6 may not have file tildeexpand. + #we now have no option but to rely on environment variables - which may not be set or may be set to an incorrect value + #as tcl <= 8.6 needs to be supported - but isn't the primary target we will allow this fallback - but raise a warning as this is not ideal. + puts stderr "punk::nav::fs::~ Warning: Unable to determine home directory for user '$user' using 'file tildeexpand ~$user'. Falling back to environment variables, which may not be set or may be incorrect. Consider upgrading to Tcl 9.0 or later for improved reliability." + if {"windows" eq $::tcl_platform(platform)} { + if {[info exists ::env(USERPROFILE)]} { + set hdir [punk::valcopy $::env(USERPROFILE)] + } else { + set hdir "" + } + } else { + if {[info exists ::env(HOME)]} { + set hdir [punk::valcopy $::env(HOME)] + } else { + set hdir "" + } + } + } + } + } + } + + if {$hdir eq ""} { + error "punk::nav::fs::~ Unable to determine home directory for user '$user'. Consider upgrading to Tcl 9.0 or later for improved reliability in home directory detection." + } + + file pathtype $hdir ;#flips internal-rep to path + if {![file isdirectory $hdir]} { + #file isdirectory should also return true if the path exists and is a symlink to a directory - but if it doesn't exist at all - or is a file - then we have a problem. + error "punk::nav::fs::~ Determined home directory path '$hdir' does not exist (or is not a directory)." + } else { + if {![file readable $hdir]} { + error "punk::nav::fs::~ Determined home directory path '$hdir' is not readable." + } + } + + set user_home_cache $hdir ;#cache only the home directory. + + set d $hdir + #use the file join 2-arg optimisation to avoid losing path-rep - probably doesn't give any advantage on all Tcl versions + #review - for what versions does/did the 2-arg version of file join not just return a string? + foreach a $args { + set d [file join $d $a] + } + file pathtype $d + return [punk::valcopy $d] + } + punk::args::define { @id -id ::punk::nav::fs::d/ @cmd -name punk::nav::fs::d/ -help\ @@ -624,9 +795,11 @@ tcl::namespace::eval punk::nav::fs { return $result } + + #---------------------------------------------------- punk::args::define { - @id -id ::punk::nav::fs::d/new - @cmd -name punk::nav::fs::d/new\ + @id -id ::punk::nav::fs::newdir + @cmd -name punk::nav::fs::newdir\ -summary\ "Create directory or directories at the specified path(s)."\ -help\ @@ -662,9 +835,9 @@ tcl::namespace::eval punk::nav::fs { created for some reason (e.g other filesystem error) then an error will be raised and processing of any remaining paths will be aborted." } - #todo - synchronize overall behaviour of d/new with that of n/new (for namespaces) - proc d/new {args} { - set argd [punk::args::parse $args withid ::punk::nav::fs::d/new] + #todo - synchronize overall behaviour of newdir with that of newns (for namespaces) + proc newdir {args} { + set argd [punk::args::parse $args withid ::punk::nav::fs::newdir] lassign [dict values $argd] leaders opts values received set paths [dict get $values path] set allow_nonportable [dict exists $received -nonportable] @@ -678,12 +851,12 @@ tcl::namespace::eval punk::nav::fs { set error_paths [list] foreach p $paths { if {!$allow_nonportable && [punk::winpath::illegalname_test $p]} { - #error "punk::nav::fs::d/new Path '$p' is not portable and may not be created without -nonportable option" + #error "punk::nav::fs::newdir Path '$p' is not portable and may not be created without -nonportable option" lappend error_paths [list $p "Path '$p' is not portable and may not be created without -nonportable option"] continue } if {[string first \0 $p] != -1} { - #error "punk::nav::fs::d/new Path '$p' contains null character which is not allowed" + #error "punk::nav::fs::newdir Path '$p' contains null character which is not allowed" lappend error_paths [list $p "Path '$p' contains null character which is not allowed"] continue } @@ -699,7 +872,7 @@ tcl::namespace::eval punk::nav::fs { set parent [file dirname $parent] } if {![file writable $parent]} { - #error "punk::nav::fs::d/new Cannot create directory '$fullpath' as parent '$parent' is not writable" + #error "punk::nav::fs::newdir Cannot create directory '$fullpath' as parent '$parent' is not writable" lappend error_paths [list $fullpath "Cannot create directory '$fullpath' as parent '$parent' is not writable"] continue } @@ -713,7 +886,7 @@ tcl::namespace::eval punk::nav::fs { set m [lindex $e 1] append path_error_display " Path: '$p' Error: $m\n" } - error "punk::nav::fs::d/new One or more supplied paths were invalid or not writable:\n$path_error_display" + error "punk::nav::fs::newdir One or more supplied paths were invalid or not writable:\n$path_error_display" } set num_created 0 @@ -730,17 +903,56 @@ tcl::namespace::eval punk::nav::fs { incr num_created } if {$error_string ne ""} { - error "punk::nav::fs::d/new $error_string\n$num_created directories out of [llength $fullpath_list] were created successfully before the error was encountered." + error "punk::nav::fs::newdir $error_string\n$num_created directories out of [llength $fullpath_list] were created successfully before the error was encountered." } #display summaries of created directories (which may have already existed) by reusing d/ to get info on them. set query_paths [lmap v $paths {string cat $v "/*"}] d/ / {*}$query_paths } + #---------------------------------------------------- + - #todo use unknown to allow d/~c:/etc ?? - proc d/~ {args} { - set home $::env(HOME) + punk::args::define { + @id -id ::punk::nav::fs::lib::gohome + @cmd -name punk::nav::fs::lib::gohome\ + -summary\ + "Navigate to a path relative to the current user's home directory."\ + -help\ + "Navigate to a path relative to the user's home directory. + + This may usually correspond to the HOME environment variable, but some + tools may have pointed HOME elsewhere, so the home directory is determined + based on the current user as determined using the whoami command, which is + almost universally available on platforms that Tcl runs on, and should be + unaffected by any changes to environment variables. + + This is a convenience function for quickly navigating to commonly used + locations within the home directory, without having to type out the full + path or use environment variables. + + Like the './' command, this navigates to the folder and then lists the sub-directories, + with a summary of the number of sub-directories and files, and total file size in bytes. + + " + @values -min 1 -max -1 + path -type string -optional 1 -multiple 1 -help\ + "Path relative to home directory to navigate to. + If the path does not exist, or is not a directory, then an error will be raised. + Examples: + gohome - will navigate to $HOME + (equivalent: gohome .) + gohome subdir1/subdir2 - will navigate to $HOME/subdir1/subdir2 + (equivalent: gohome subdir1 subdir2) + gohome subdir1 - will navigate to $HOME/subdir1 + + An absolute path is also accepted, but then the navigation is not relative to the home + directory and is effectively just a normal navigation to the specified path. + (equivalent to using ./ ) + " + } + proc gohome {args} { + set home [punk::nav::fs::~] set target [file join $home {*}$args] if {![file isdirectory $target]} { error "Folder $target not found" @@ -1731,10 +1943,11 @@ tcl::namespace::eval punk::nav::fs { if {![catch {package require punk::winlnk}]} { set target_type "file" ;#default/fallback - set shortcutinfo [punk::winlnk::resolve $fname] - if {[dict exists $shortcutinfo link_target]} { + set shortcutinfo [punk::winlnk::resolve $fname] ;#will always return a dict. Will only contain error key if there was an error. + + if {[dict exists $shortcutinfo link_roottarget]} { set is_valid_lnk 1 - set tgt [dict get $shortcutinfo link_target] + set root_tgt [dict get $shortcutinfo link_roottarget] set link_target_type [dict get $shortcutinfo target_type] switch -- $link_target_type { file { @@ -1744,12 +1957,12 @@ tcl::namespace::eval punk::nav::fs { set target_type "directory" } unknown { - #fall back to checking attributes and filesystem if we have a link_target but no target_type - if {[file exists $tgt]} { + #fall back to checking attributes and filesystem if we have a link_roottarget but no target_type + if {[file exists $root_tgt]} { #file type could return 'link' - we will use isfile/isdirectory - if {[file isfile $tgt]} { + if {[file isfile $root_tgt]} { set target_type file - } elseif {[file isdirectory $tgt]} { + } elseif {[file isdirectory $root_tgt]} { set target_type directory } else { set target_type file ;## ? @@ -1761,26 +1974,32 @@ tcl::namespace::eval punk::nav::fs { } } } else { - #no link_target - probably an ordinary file - but there could have been some other error in reading the binary windows lnk format. + #no link_roottarget - probably an ordinary file - but there could have been some other error in reading the binary windows lnk format. set is_valid_lnk 0 } if {$is_valid_lnk} { switch -- $target_type { file { set display [dict get $fdict display] - set display "$fshortcut_style$display (shortcut $tgt)" ;# + if {[dict exists $shortcutinfo stringdata command_line_arguments]} { + set display "$fshortcut_style$display (shortcut to $root_tgt [dict get $shortcutinfo stringdata command_line_arguments])" + } else { + set display "$fshortcut_style$display (shortcut $root_tgt)" ;# + } dict set fdict display $display lappend finfo_plus $fdict } directory { #target of link is a dir - for display/categorisation purposes we want to see it as a dir #will be styled later based on membership of dir_shortcuts + #review: we shouldn't see a link to a dir that also has command_line_arguments + #- but if we do, we will just ignore the command_line_arguments for now and treat as a directory shortcut. lappend dirs $fname lappend dir_shortcuts $fname } } } else { - #we were unable to get link_target - but we still need to check if it failed the header check (then assume not intended to be a windows shell lnk) or for some other reason. + #we were unable to get link_roottarget - but we still need to check if it failed the header check (then assume not intended to be a windows shell lnk) or for some other reason. if {[dict exists $shortcutinfo error]} { if {[dict get $shortcutinfo error] ne "lnk_header_check_failed"} { #Presumably there is a valid lnk header, but some unexpected error occurred - show it in the display for the file @@ -1794,9 +2013,10 @@ tcl::namespace::eval punk::nav::fs { lappend finfo_plus $fdict } } else { - #shouldn't ever happen. If no error, then there should have been a link_target + #shouldn't ever happen. If no error, then there should have been a link_roottarget #report and move on - puts stderr "Unexpected error in result of parsing binary format for $fname" + puts stderr "Unexpected error in result of parsing binary format for $fname." + puts stderr "Result was [showdict $shortcutinfo]" lappend finfo_plus $fdict } } @@ -2079,6 +2299,7 @@ tcl::namespace::eval punk::nav::fs::system { } +interp alias {} ~ {} punk::nav::fs::~ interp alias {} ./ {} punk::nav::fs::d/ / interp alias {} d/ {} punk::nav::fs::d/ / interp alias {} .// {} punk::nav::fs::d/ // @@ -2093,10 +2314,12 @@ interp alias {} dirfiles {} punk::nav::fs::dirfiles interp alias {} dirfiles_dict {} punk::nav::fs::dirfiles_dict interp alias {} fglob {} punk::nav::fs::fglob -interp alias {} ./new {} punk::nav::fs::d/new -interp alias {} d/new {} punk::nav::fs::d/new -interp alias {} ./~ {} punk::nav::fs::d/~ -interp alias {} d/~ {} punk::nav::fs::d/~ +interp alias {} newdir {} punk::nav::fs::newdir + +#this also conflicts with auto_cd as there could be a local folder (or file) called ~. +interp alias {} gohome {} punk::nav::fs::gohome + +#review interp alias {} x/ {} punk::nav::fs::x/ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ diff --git a/src/modules/punk/nav/ns-999999.0a1.0.tm b/src/modules/punk/nav/ns-999999.0a1.0.tm index 3ab5a6be..732a5887 100644 --- a/src/modules/punk/nav/ns-999999.0a1.0.tm +++ b/src/modules/punk/nav/ns-999999.0a1.0.tm @@ -94,7 +94,8 @@ tcl::namespace::eval punk::nav::ns { if {[llength $ensemble_info] > 0} { #this namespace happens to match ensemble command. #todo - keep cache of encountered ensembles from commands.. and examine namespace in the configure info. - set ns_display "\n[a+ yellow bold]$ns_current (ensemble)[a+]" + #don't rely on a+ alias here. + set ns_display "\n[punk::ansi::a+ yellow bold]$ns_current (ensemble)[punk::ansi::a+]" } } } @@ -103,11 +104,86 @@ tcl::namespace::eval punk::nav::ns { return $out } - #create possibly nested namespace structure - but only if not already existant - proc n/new {args} { + #create possibly nested namespace structure(s) - todo: allow specifying namespaces or which already or partially already exist. + #todo - sync with newdir behaviour. + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::punk::nav::ns::newns + @cmd -name punk::nav::ns::newns\ + -summary\ + "Create namespace or namespaces at the specified path(s)."\ + -help\ + "This command creates namespaces at the specified path(s). + If any part of the specified path does not exist, then it will be created as well. + If a specified path already exists, then it will be left as-is and no error will be raised. + + A summary line is returned for each created namespace, with the full path of the created + namespace and a status line indicating the number of child namespaces, commands and vars in + the namespace if it already existed (or showing 0 for all if it was just created). + (summary incomplete - todo)" + -force -type none\ + -help\ + "Allows creation of namespaces which may be unwise/problematic, such as empty string + or namespaces with leading colons. + Use with caution and only when you know what you are doing. + If -force is not supplied, then an error will be raised if any supplied + path is problematic and no namespaces will be created." + @values -min 1 -max -1 -type string + path -type string -multiple 1 -optional 0 -help\ + "Path(s) (possibly with namespace separator ::) to create. + Can be absolute or relative to current namespace. + If any path is rejected, then no namespaces will be created. + + If a namespace or part of a namespace already exists, then it will be left as-is and no + error will be raised. + + If despite passing the name tests, a namespace cannot be created for some reason then an + error will be raised and processing of any remaining paths will be aborted." + }] + } + proc newns {args} { + set argd [punk::args::parse $args withid ::punk::nav::ns::newns] + lassign [dict values $argd] _leaders opts values _received + if {[dict exists $opts -force]} { + set opt_force [dict get $opts -force] + } else { + set opt_force 0 + } + set paths [dict get $values path] + + variable ns_current + + #todo: like newdir we want to try to perform an all-or-nothing operation - so first validate all namespaces to be created before creating any of them. + + set ns [lindex $paths 0] ;#temporary - full implementation will loop through $paths. + set is_absolute [string match ::* $ns] + if {$is_absolute} { + set nspath $ns + } else { + if {[string match :* $ns]} { + #todo - disallow by default and require flag to force. + #we also should disallow by default ::: (or any odd multiple? perhaps even :::: for empty ns should require -force) in between segments. + puts stderr "newns WARNING namespace with leading colon '$ns' is likely to have unexpected results" + } + set nspath [nsjoin $ns_current $ns] + } + + set ns_exists [nseval [nsprefix $nspath] [list ::tcl::namespace::exists [nstail $nspath] ]] + + if {$ns_exists} { + error "Namespace $nspath already exists" + } + #tcl::namespace::eval [nsprefix $nspath] [list tcl::namespace::eval [nstail $nspath] {}] + nseval [nsprefix $nspath] [list ::tcl::namespace::eval [nstail $nspath] {}] + + #display summaries of created directories (which may have already existed) by reusing d/ to get info on them. + set query_paths [lmap v $paths {string cat $v "::*"}] + ns/ / {*}$query_paths + } + proc newns_old {args} { variable ns_current if {![llength $args]} { - error "usage: :/new \[ ...\]" + error "usage: newns \[ ...\]" } set a1 [lindex $args 0] set is_absolute [string match ::* $a1] @@ -115,7 +191,7 @@ tcl::namespace::eval punk::nav::ns { set nspath [nsjoinall {*}$args] } else { if {[string match :* $a1]} { - puts stderr "n/new WARNING namespace with leading colon '$a1' is likely to have unexpected results" + puts stderr "newns WARNING namespace with leading colon '$a1' is likely to have unexpected results" } set nspath [nsjoinall $ns_current {*}$args] } @@ -130,6 +206,7 @@ tcl::namespace::eval punk::nav::ns { n/ $nspath } + #nn/ ::/ nsup/ - back up one namespace level proc nsup/ {v args} { variable ns_current @@ -160,14 +237,13 @@ tcl::namespace::eval punk::nav::ns { interp alias {} n/ {} punk::nav::ns::ns/ / interp alias {} n// {} punk::nav::ns::ns/ // interp alias {} n/// {} punk::nav::ns::ns/ /// -interp alias {} n/new {} punk::nav::ns::n/new +interp alias {} newns {} punk::nav::ns::newns interp alias {} nn/ {} punk::nav::ns::nsup/ / interp alias {} nn// {} punk::nav::ns::nsup/ // if 0 { -#we can't have ::/ without just plain / which is confusing. interp alias {} :/ {} punk::nav::ns::ns/ / interp alias {} :// {} punk::nav::ns::ns/ // -interp alias {} :/new {} punk::nav::ns::n/new +#we can't have ::/ without just plain / which is confusing. interp alias {} ::/ {} punk::nav::ns::nsup/ / interp alias {} ::// {} punk::nav::ns::nsup/ // } diff --git a/src/modules/punk/netbox-999999.0a1.0.tm b/src/modules/punk/netbox-999999.0a1.0.tm index ad7469dc..d4738654 100644 --- a/src/modules/punk/netbox-999999.0a1.0.tm +++ b/src/modules/punk/netbox-999999.0a1.0.tm @@ -1323,13 +1323,15 @@ tcl::namespace::eval punk::netbox { proc _homedir {} { - if {[info exists ::env(HOME)]} { - set home [file normalize $::env(HOME)] - } else { - #not available on 8.6? ok will error out here. - set home [file tildeexpand ~] - } - return $home + package require punk::nav::fs + punk::nav::fs::~ + #if {[info exists ::env(HOME)]} { + # set home [file normalize $::env(HOME)] + #} else { + # #not available on 8.6? ok will error out here. + # set home [file tildeexpand ~] + #} + #return $home } lappend PUNKARGS [list { @id -id ::punk::netbox::_datafile @@ -1367,23 +1369,33 @@ tcl::namespace::eval punk::netbox { lassign [dict values $argd] leaders opts values received set be_quiet [dict exists $received -quiet] + set data_home "" set was_noisy 0 if {[info exists ::env(XDG_DATA_HOME)]} { set data_home $::env(XDG_DATA_HOME) } else { if {$::tcl_platform(platform) eq "windows"} { - set data_home $::env(LOCALAPPDATA) + if {[info exists ::env(LOCALAPPDATA)]} { + set data_home $::env(LOCALAPPDATA) + } else { + if {!$be_quiet} { + puts stderr "Environment variable LOCALAPPDATA does not exist - consider setting it if /.local/share is not a suitable location" + set was_noisy 1 + } + } } else { - set data_home [file join [_homedir] .local share] if {!$be_quiet} { - puts stderr "Environment variable XDG_DATA_HOME does not exist - consider setting it if $data_home is not a suitable location" + puts stderr "Environment variable XDG_DATA_HOME does not exist - consider setting it if /.local/share is not a suitable location" set was_noisy 1 } } + if {$data_home eq ""} { + set data_home [file join [_homedir] .local share] + } } if {!$be_quiet && ![file exists $data_home]} { #parent folder for 'punk' config dir doesn't exist - set msg "configuration location XDG_DATA_HOME or ~/.local/share (or LOCALAPPDATA on windows) at path '$data_home' does not yet exist" + set msg "configuration location XDG_DATA_HOME or /.local/share (or LOCALAPPDATA on windows) at path '$data_home' does not yet exist" append msg \n " - please create it and/or set the appropriate env var." puts stderr $msg set was_noisy 1 diff --git a/src/modules/punk/ns-999999.0a1.0.tm b/src/modules/punk/ns-999999.0a1.0.tm index 4d534c02..ff00691d 100644 --- a/src/modules/punk/ns-999999.0a1.0.tm +++ b/src/modules/punk/ns-999999.0a1.0.tm @@ -3416,8 +3416,8 @@ y" {return quirkykeyscript} lappend usageinfo $c set found_documentation 1 } - #todo - alias to an alias - #e.g n/new jjj + #todo? - alias to an alias + #e.g newns jjj # interp alias "" ::jjj::corp2 "" ::corp #todo -pseudocode #cmdwhich id diff --git a/src/modules/punk/winlnk-999999.0a1.0.tm b/src/modules/punk/winlnk-999999.0a1.0.tm index 75393909..788f4bcc 100644 --- a/src/modules/punk/winlnk-999999.0a1.0.tm +++ b/src/modules/punk/winlnk-999999.0a1.0.tm @@ -75,6 +75,10 @@ tcl::namespace::eval punk::winlnk { #[para] Core API functions for punk::winlnk #[list_begin definitions] + #todo - review internal API. + #A lot of these functions accept the raw contents of a .lnk file. + #It may make sense to use an OO approach to avoid reparsing of contents when calling multiple functions on the same .lnk file. + variable magic_HeaderSize "0000004C" ;#HeaderSize MUST equal this variable magic_LinkCLSID "00021401-0000-0000-C000-000000000046" ;#LinkCLSID MUST equal this @@ -853,14 +857,14 @@ tcl::namespace::eval punk::winlnk { set suffix_path "" set linkinfocontent [dict get $linkinfo_content_dict content] set next_start [dict get $linkinfo_content_dict next_start] ;#location of section following LinkInfo (Location information) - this will be the Data Strings. - set link_target "" + set link_roottarget "" set linkfields [dict create] if {$linkinfocontent ne ""} { set linkfields [LinkInfo_get_fields $linkinfocontent] set localbase_path [dict get $linkfields localbasepath] set suffix_path [dict get $linkfields commonpathsuffix] if {"windows" eq $::tcl_platform(platform)} { - set link_target [file join $localbase_path $suffix_path] + set link_roottarget [file join $localbase_path $suffix_path] } else { #review - calling mount and parsing its output every time we parse a .lnk file makes this slow on large folders with .lnk files # - we may want to cache the results of mount for some period of time or until we detect a change in the system's mounts (e.g. by monitoring /proc/mounts for changes or using a filesystem watcher on /mnt) @@ -868,24 +872,24 @@ tcl::namespace::eval punk::winlnk { if {[regexp {([a-zA-Z]):\\(.*)} $localbase_path _match drive_letter tail]} { set localbase_path [string map {\\ /} $localbase_path] set tail [string trimleft [string map {\\ /} $tail] /] - set link_target "" + set link_roottarget "" #shortcut basepath is a windows path with drive letter - try to resolve it on unix by looking for a corresponding mount from fstab or a point under /mnt set mountinfo [exec mount] foreach line [split $mountinfo "\n"] { #review - a more specific mount target might exist that includes the drive letter as part of the mount point name and is a longer prefix of the localbase_path #- we should probably look for the longest prefix match rather than just the drive letter if {[regexp -nocase -- [string cat ^$drive_letter {:\\\s+on\s+(\S+)}] $line _match mount_point]} { - set link_target [file join $mount_point $tail $suffix_path] + set link_roottarget [file join $mount_point $tail $suffix_path] break } } - if {$link_target eq ""} { + if {$link_roottarget eq ""} { #review - under what circumstances could this happen? If the drive letter doesn't match any mount points, then /mnt/drive_letter should generally already have been found above above # - However, it may be possible for /mnt/drive_Letter to still exist even if it's not reflected in the output of mount or the output of mount is in an unexpected format. #nothing in mount result matches the drive letter - try looking for a mount point under /mnt with the drive letter as the name if {[file exists /mnt/$drive_letter]} { - set link_target [file join /mnt/$drive_letter $tail $suffix_path] + set link_roottarget [file join /mnt/$drive_letter $tail $suffix_path] } else { if {$drive_letter eq [string tolower $drive_letter]} { set op_drive_letter [string toupper $drive_letter] @@ -893,20 +897,20 @@ tcl::namespace::eval punk::winlnk { set op_drive_letter [string tolower $drive_letter] } if {[file exists /mnt/$op_drive_letter]} { - set link_target [file join /mnt/$op_drive_letter $tail $suffix_path] + set link_roottarget [file join /mnt/$op_drive_letter $tail $suffix_path] } else { #leave as is except for backslashes converted to forward #- probably won't resolve correctly unless the unix system has a folder named drive_letter: in the current folder with a copy of the original filestructure. - set link_target [file join $localbase_path $suffix_path] + set link_roottarget [file join $localbase_path $suffix_path] } } } else { - #shortcut basepath is a windows path with drive letter and we found a matching mount point - link_target is set to the resolved path + #shortcut basepath is a windows path with drive letter and we found a matching mount point - link_roottarget is set to the resolved path } } else { #shortcut basepath doesn't match expected windows path format - just join it with the suffix and hope for the best #could be something like a network path or it could be something else entirely - set link_target [file join $localbase_path $suffix_path] + set link_roottarget [file join $localbase_path $suffix_path] } } } @@ -929,14 +933,14 @@ tcl::namespace::eval punk::winlnk { set target_type [dict get $target_type_info type] set target_type_mech [dict get $target_type_info mechanism] if {$target_type eq "unknown"} { - if {[file exists $link_target]} { - set target_type [file type $link_target] + if {[file exists $link_roottarget]} { + set target_type [file type $link_roottarget] set target_type_mech "filesystem" } } set result [dict create\ - link_target $link_target\ + link_roottarget $link_roottarget\ link_flags $flags_enabled\ file_attributes $file_attributes\ creation_time [Header_Get_CreationTime $contents]\ @@ -1007,7 +1011,7 @@ tcl::namespace::eval punk::winlnk { -summary\ "Show information about a .lnk file (windows shortcut)"\ -help\ - "Print to stdout the information obtained by parsing the binary data in a windows .lnk file, in a human readable format. + "Return information obtained by parsing the binary data in a windows .lnk file, in a human readable format. If the .lnk header check fails, then the .lnk file probably isn't really a shortcut file and an error message will be printed." @values -min 1 -max 1 path -type string -help "Path to the .lnk file to resolve" @@ -1017,7 +1021,7 @@ tcl::namespace::eval punk::winlnk { package require punk::lib #punk::lib::showdict [resolve $path] */@* set field_queries [dict create\ - link_target link_target\ + link_roottarget link_roottarget\ link_flags link_flags/@*\ file_attributes file_attributes\ creation_time creation_time\ @@ -1044,7 +1048,7 @@ tcl::namespace::eval punk::winlnk { append querystring "$field " } } - puts "querystring: $querystring" + #puts "querystring: $querystring" return [punk::lib::showdict $info {*}$querystring] } } @@ -1055,32 +1059,33 @@ tcl::namespace::eval punk::winlnk { @id -id ::punk::winlnk::target @cmd -name punk::winlnk::target\ -summary\ - "Return the target path of a .lnk file (windows shortcut)"\ + "Return the target path/commandline of a .lnk file (windows shortcut)"\ -help\ - "Return the target path of the .lnk file specified in path. + "Return the target path/commandline of the .lnk file specified in path. This is a convenience function that extracts the target path from the .lnk file and returns it directly, without all the additional information that resolve provides. If the .lnk header check fails, then - the .lnk file probably isn't really a shortcut file and an error message will be returned. - - Incomplete! - needs to process arguments when HasArguments link flag is set and append the arguments to the target path. - - e.g for a shortcut to 'START /D ...' the target will currently just return a path to cmd.exe - which is insufficient." + the .lnk file probably isn't really a shortcut file and an error message will be returned." @values -min 1 -max 1 path -type string -help "Path to the .lnk file to resolve" }] } + #consider a shortcut to the following: # START /D ^"C:\tcl\bin^" wish.exe c:\cmdfiles\ftp.tcl" - # the target currently only returns c:/Windows/System32/cmd.exe. + # the link_roottarget is c:/Windows/System32/cmd.exe. + proc target {path} { - #*** !doctools - #[call [fun target] [arg path] ] - #[para]Return the target path of the .lnk file specified in path set info [resolve $path] if {[dict exists $info error]} { error [dict get $info error] } else { - return [dict get $info link_target] + set roottarget [dict get $info link_roottarget] + if {[dict exists $info stringdata command_line_arguments]} { + set arguments [dict get $info stringdata command_line_arguments] + return "$roottarget $arguments" + } else { + return $roottarget + } } } @@ -1094,7 +1099,9 @@ tcl::namespace::eval punk::winlnk { } proc Get_target_type {content file_attributes} { - #determine type based on info in the .lnk file, such as file attributes and link flags + #determine target file/directory/link type based on info in the .lnk file, such as file attributes and link flags + #review - a .lnk may target an executable with arguments. + #In this case, the target type may be considered a file (the executable) but it may also be useful to indicate that it's a link to an executable with arguments(?). if {"DIRECTORY" in $file_attributes} { return [dict create type directory mechanism file_attributes]" @@ -1104,31 +1111,31 @@ tcl::namespace::eval punk::winlnk { set iteminfo [Get_LinkTargetIDList_iteminfo $content] if {[llength $iteminfo] > 0} { set first_item [lindex $iteminfo 0] - set first_item_type [dict get $first_item type] + set first_item_type [dict get $first_item typehex] set saw_2f 0 switch -- $first_item_type { "1F" { #plain files and folders always seem to have a first item type of 1F #so does "local disk" - set type_so_far "unknown" - #For a file, we may first see multiple items of type 32 (directory) as we go through the folder structure, - #and then finally an item of type 31 (file) at the end. + set target_type_so_far "unknown" + #For a file, we may first see multiple items of typehex 32 (directory) as we go through the folder structure, + #and then finally an item of typehex 31 (file) at the end. #For a network location, we may see an item of type 2F. #So we need to loop through all the items and keep track of what we've seen so far. foreach item $iteminfo { - set item_type [dict get $item type] - if {$item_type eq "31"} { - set type_so_far "directory" - } elseif {$item_type eq "32"} { + set item_type_hex [dict get $item typehex] + if {$item_type_hex eq "31"} { + set target_type_so_far "directory" + } elseif {$item_type_hex eq "32"} { return [dict create type file mechanism idlist] - } elseif {$item_type eq "2F"} { + } elseif {$item_type_hex eq "2F"} { set saw_2f 1 } } - if {$type_so_far eq "unknown" && $saw_2f} { + if {$target_type_so_far eq "unknown" && $saw_2f} { return [dict create type "local disk" mechanism idlist] } - return [dict create type $type_so_far mechanism idlist] + return [dict create type $target_type_so_far mechanism idlist] } } return [dict create type "unknown" mechanism idlist] diff --git a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/choices.test b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/choices.test index 59bfde73..3a72e93e 100644 --- a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/choices.test +++ b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/choices.test @@ -86,7 +86,34 @@ namespace eval ::testspace { ok_got_expected_error2\ ] - test choice_multiple_multiple {test -choice with both -multiple and -choicemultiple}\ + test choice_multiple_with_choiceprefix {test -choices with both -multiple and -choiceprefix}\ + -setup $common -body { + #test with full value choices. + set argd [punk::args::parse {license description} withdef @values {topic -choices {license contributors description} -choiceprefix 1 -multiple 1 }] + lappend result [dict get $argd values] + + #test with prefixes of choice. + set argd [punk::args::parse {lic desc} withdef @values {topic -choices {license contributors description} -choiceprefix 1 -multiple 1 }] + lappend result [dict get $argd values] + + #test with mixes of full value and prefix of choice. + set argd [punk::args::parse {license desc} withdef @values {topic -choices {license contributors description} -choiceprefix 1 -multiple 1 }] + lappend result [dict get $argd values] + + set argd [punk::args::parse {desc license} withdef @values {topic -choices {license contributors description} -choiceprefix 1 -multiple 1 }] + lappend result [dict get $argd values] + }\ + -cleanup { + }\ + -result [list\ + {topic {license description}}\ + {topic {license description}}\ + {topic {license description}}\ + {topic {description license}}\ + ] + #todo -nocase tests + + test choice_multiple_multiple {test -choices with both -multiple and -choicemultiple}\ -setup $common -body { set argd [punk::args::parse {a {c a} {a b c}} withdef @values {X -type string -choices {aa bb cc} -multiple 1 -choicemultiple {1 3} -optional 1}] lappend result [dict get $argd values] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/commandstack-0.4.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/commandstack-0.4.tm index 19c21289..165bd16a 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/commandstack-0.4.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/commandstack-0.4.tm @@ -167,6 +167,12 @@ namespace eval commandstack { lassign $arglist command procargs procbody set command [uplevel 1 [list namespace which $command]] + if {$command eq ""} { + #review + puts stderr "commandstack::rename_command no rename performed for command '$command' by '$renamer'. command '$command' not found in calling context. Ensure command name is fully qualified or that command exists." + #add something to stack? + return [dict create implementation ""] + } set mungedcommand [string map {:: _ns_} $command] set mungedrenamer [string map {:: _ns_} $renamer] variable all_stacks @@ -284,7 +290,8 @@ namespace eval commandstack { ] if {![dict get $nextinfo do_rename]} { #review - puts stderr "no rename performed" + puts stderr "commandstack::rename_command no rename performed for command '$command' by '$renamer'" + #add something to stack? return [dict create implementation ""] } catch {rename ::commandstack::temp::testproc ""} diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm index 5a7824f0..ebfb673f 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm @@ -35,29 +35,13 @@ namespace eval punk { " } - proc rehash {{refresh 0}} { - global auto_execs - if {!$refresh} { - unset -nocomplain auto_execs - } else { - set names [array names auto_execs] - unset -nocomplain auto_execs - foreach nm $names { - auto_execok_windows $nm - } - } - return - } proc ::punk::auto_execok_original name [info body ::auto_execok] variable better_autoexec - #set better_autoexec 0 ;#use this var via better_autoexec only - #proc ::punk::auto_execok_windows name { - # ::punk::auto_execok_original $name - #} + #use this var via better_autoexec only set better_autoexec 1 proc ::punk::auto_execok_windows name { ::punk::auto_execok_better $name @@ -166,14 +150,14 @@ namespace eval punk { proc ::punk::auto_execok_windows name { ::punk::auto_execok_better $name } - punk::rehash + punk::auto_exec::rehash } elseif {!$onoff && ($onoff != $better_autoexec)} { puts "Turning off better_autoexec - search extension then PATH" set better_autoexec 0 proc ::punk::auto_execok_windows name { ::punk::auto_execok_original $name } - punk::rehash + punk::auto_exec::rehash } else { puts "no change" } @@ -182,6 +166,16 @@ namespace eval punk { proc auto_execok_better name { + #review - we have a gneral problem of auto_exec caching negative results for relative paths. + #A failed resolution of a relative path should not generate an entry in ::auto_execs. + #This happens in plain tclsh - so we need to determine where in Tcl this happens and fix it there. + #Simply returning an empty string here will still result in a negative cache entry. + #we want to cache negative results for absolute paths or plain filenames with no file-separator. + #e.g ./doesntexist.exe should not be cached as not found, but should be re-resolved every time. (cwd dependent) + #e.g doesntexist.exe should be cached as not found, because it will always be not found until it appears in the PATH. + #i.e it is required to prefix with ./ to exec a file in the current directory. (similar to unix shells) + + global auto_execs env tcl_platform #for now at least, auto_execok_better is windows-specific. package require punk::auto_exec @@ -213,7 +207,16 @@ namespace eval punk { } if {[llength [file split $name]] != 1} { + #----------------------------------------------------- #has a path component - could be relative or absolute. + #----------------------------------------------------- + if {[file pathtype $name] eq "relative"} { + #don't cache negative result for any relative paths - as they may become valid if the file appears in the relative location, or if the user changes directory and the same relative path points to a different file. + #our only way to do this is by cooperating with the unknown handler. + set auto_execs($name) "for_unknown_handler by punk::auto_exec relative_path - file existence should be re-checked at call time" + return $auto_execs($name) + } + if {[string tolower [file extension $name]] eq ".lnk"} { #special case .lnk #todo - consider working directory or other properties of link before launching? @@ -246,11 +249,11 @@ namespace eval punk { set associnfo [punk::auto_exec::shell_open_command $test_ext] set valuetype [dict get $associnfo type] set assoc [dict get $associnfo value] - set ftype [dict get $associnfo filetype] + set windows_file_type [dict get $associnfo filetype] if {$assoc eq ""} { return [set auto_execs($name) [list $file]] } else { - if {[file pathtype $target] eq "relative" && $ftype eq "InternetShortcut"} { + if {[file pathtype $target] eq "relative" && $windows_file_type eq "InternetShortcut"} { #special case InternetShortcut - cannot accept relative path - so we can't cache it in auto_execs if we used a relative path to launch #if we return an empty string - the auto_exec will fail to launch this every time. #The best we can do is return a token for the 'unknown' process to detect and re-resolve the path every time. @@ -260,7 +263,7 @@ namespace eval punk { #e.g ::auto_execs(./link.url) = some.exe c:/desktop/link.url #this would be wrong if the user changed directory and tried to run ./link.url again on a different file with the same name # - as the cached path would no longer be correct. - return [set auto_execs($name) "(resolve_in_unknown_handler) punk::auto_exec absolute_path required"] + return [set auto_execs($name) "for_unknown_handler by punk::auto_exec absolute_path required"] } puts stderr "auto_execok_better: (review required) assoc $assoc for file $file ext $test_ext" set run [punk::auto_exec::shell_command_as_tcl_list -type $valuetype $assoc $file] ;# -workingdir [pwd] vs path of script? @@ -269,6 +272,8 @@ namespace eval punk { } } } + #cache negative result for absolute paths - as they will always point to the same location, so if they don't exist now, they won't exist later. + set auto_execs($name) "" return "" } @@ -559,7 +564,7 @@ if {![llength [info commands ::ansistring]]} { package require punk::repl::codethread package require punk::config #package require textblock -package require punk::console ;#requires Thread +catch {package require punk::console} ;#requires Thread - will not work in safe interps. package require punk::ns package require punk::winpath ;# for windows paths - but has functions that can be called on unix systems package require punk::repo @@ -5396,27 +5401,54 @@ namespace eval punk { } else { set repl_runid [punk::get_repl_runid] #set ::punk::last_run_display [list] - if {$new eq "(resolve_in_unknown_handler) punk::auto_exec absolute_path required"} { - #re-resolve. - puts "(unknown-handler): auto_execok for $name requires absolute path. Re-resolving $name with absolute path." + set resolved $new + if {[string match "for_unknown_handler *" $new]} { set ext [file extension $name] - set associnfo [punk::auto_exec::shell_open_command $ext] - set valuetype [dict get $associnfo type] - set assoc [dict get $associnfo value] - set ftype [dict get $associnfo filetype] - set fullpath [file normalize $name] - #at least for .url files - long paths (paths with multiple spaces?) can fail to run. Using the short path seems to fix this. - #This seems hacky but anyway.. - set attributes [file attributes $fullpath] - if {[dict exists $attributes -shortname]} { - set fullpath [dict get $attributes -shortname] + if {[string tolower $ext] eq ".lnk"} { + #for .lnk files we can often resolve the target path without needing to execute the shell open command + #- which is desirable because it allows us to avoid the absolute path requirement for unknown-handler auto_execok commands, + #which is desirable because it allows us to support relative paths and paths with environment variables in them + #(e.g for .lnk files that point to executables with environment variables in the path) + set targetinfo [punk::winlnk::resolve $name] + if {[dict exists $targetinfo link_roottarget]} { + set resolved [dict get $targetinfo link_roottarget] + #arguments? + } else { + puts "(unknown-handler): failed to resolve .lnk target for $name. Falling back to shell open command resolution, which may fail if absolute path is required." + } + } else { + #re-resolve. + set associnfo [punk::auto_exec::shell_open_command $ext] + set registry_valuetype [dict get $associnfo type] ;#sz vs expand_sz + set command_spec [dict get $associnfo value] + set windows_file_type [dict get $associnfo filetype] + if {[string match "*absolute_path required" $new]} { + puts "(unknown-handler): auto_execok for $name requires absolute path. Re-resolving $name with absolute path." + set fullpath [file normalize $name] + #at least for .url files - long paths (paths with multiple spaces?) can fail to run. Using the short path seems to fix this. + #This seems hacky but anyway.. + set attributes [file attributes $fullpath] + if {[dict exists $attributes -shortname]} { + set fullpath [dict get $attributes -shortname] + } + set resolved [punk::auto_exec::shell_command_as_tcl_list -type $registry_valuetype $command_spec $fullpath] + } else { + #todo + set newnorm [file normalize $name] + puts stderr "(unknown-handler): re-resolving $name with auto_execok $newnorm" + set resolved [auto_execok $newnorm] + } } - set new [punk::auto_exec::shell_command_as_tcl_list -type $valuetype $assoc $fullpath] } - + if {$resolved eq ""} { + #resolved may be emptyif auto_execok returns an empty string. + dict set ::tcl::UnknownOptions -code error + set ::tcl::UnknownResult "unresolved path '$name'" + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } set redir ">&@stdout <@stdin" - uplevel 1 [list ::catch [concat exec $redir $new [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions] + uplevel 1 [list ::catch [concat exec $redir $resolved [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions] #we can't detect stdout/stderr output from the exec #for now emit an extra \n on stderr #todo - there is probably no way around this but to somehow exec in the context of a completely separate console @@ -5502,8 +5534,7 @@ namespace eval punk { set default_cmd_search 0 if {$default_cmd_search} { if {[llength $cmds] == 1} { - uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] \ - ::tcl::UnknownResult ::tcl::UnknownOptions] + uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] ::tcl::UnknownResult ::tcl::UnknownOptions] dict incr ::tcl::UnknownOptions -level return -options $::tcl::UnknownOptions $::tcl::UnknownResult } @@ -6779,46 +6810,6 @@ namespace eval punk { - #tilde - #These aliases work fine for interactive use - but the result is always a string int-rep - #interp alias {} ~ {} file join $::env(HOME) ;#HOME must be capitalized to work cross platform (lowercase home works on windows - but probably not elsewhere) - #interp alias {} ~ {} apply {args {file join $::env(HOME) $args}} - namespace eval argdoc { - punk::args::define { - @id -id ::punk::~ - @cmd -name "punk::~"\ - -summary\ - "Return home directory"\ - -help\ - "Return the home directory path. With additional arguments, - return the path obtained by joining the home directory with - the supplied arguments. - - usage e.g - cd [~] - (change to home directory) - .// [~] .config - (change to .config directory within home directory - and list contents.) - " - @opts - @values -min 0 -max -1 - arg -type any -optional 1 -multiple 1 - } - } - proc ~ {args} { - set hdir [punk::valcopy $::env(HOME)] - file pathtype $hdir - set d $hdir - #use the file join 2-arg optimisation to avoid losing path-rep - probably doesn't give any advantage on all Tcl versions - #review - for what versions does/did the 2-arg version of file join not just return a string? - foreach a $args { - set d [file join $d $a] - } - file pathtype $d - return [punk::valcopy $d] - } - interp alias {} ~ {} punk::~ #maint - punk::args has similar @@ -7735,12 +7726,20 @@ namespace eval punk { -limit -type int -default 20 -help\ "When multiple values are passed to inspect - limit the number of elements displayed in -channel output. + When truncation has occured an elipsis indication (...) will be appended. e.g - .= lseq 20 to 50 by 3 |> .=>* inspect -limit 4 -- |> .=>* tcl::mathop::+ - (11) 20 23 26 29... + ${[punk::args::helpers::example { - - 385 + .= lseq 20 to 50 by 3 |> .=>* inspect -limit 4 -- |> .=>* tcl::mathop::+ + (11) 20 23 26 29... + + - 385 + + }]} + + If the current pipeline data is not a list, the limit is applied to the + number of lines in the pipeline value. For no limit - use -limit -1 " @@ -7881,11 +7880,11 @@ namespace eval punk { } if {$showcount} { set displaycount "[a purple bold]($count)[a] " - if {$showcount} { - set countspace [expr {[string length $count] + 3}] ;#lhs margin size of count number plus brackets and one space - set margin [string repeat " " $countspace] - set displayval [string map [list \r "" \n "\n$margin"] $displayval] - } + #if {$showcount} { + # set countspace [expr {[string length $count] + 3}] ;#lhs margin size of count number plus brackets and one space + # set margin [string repeat " " $countspace] + # set displayval [string map [list \r "" \n "\n$margin"] $displayval] + #} } else { set displaycount "" } @@ -7934,10 +7933,13 @@ namespace eval punk { } if {![string length $more]} { - puts $channel "$displaycount$label$displayval[a]" + #puts $channel "$displaycount$label$displayval[a]" + set chunk [textblock::join -- $displaycount$label " " $displayval[a]] } else { - puts $channel "$displaycount$label$displayval[a yellow bold]$more[a]" + #puts $channel "$displaycount$label$displayval[a yellow bold]$more[a]" + set chunk [textblock::join -- $displaycount$label " " "$displayval[a yellow bold]$more[a]"] } + puts $channel $chunk return $val } @@ -8024,7 +8026,7 @@ namespace eval punk { lappend cmdinfo [list ./ "?${I}glob${NI}?" "view/change dir, list dirs."] lappend cmdinfo [list ../ "?${I}path${NI}" "go up one dir, then to path if given"] lappend cmdinfo [list .// "?${I}glob${NI}?" "view/change dir, list dirs and files"] - lappend cmdinfo [list ./new "${I}subdir${NI}..." "make new dir or dirs and show status"] + lappend cmdinfo [list newdir "${I}subdir${NI}..." "make new dir or dirs and show status"] lappend cmdinfo [list fcat "${I}file ?file?...${NI}" "cat file(s)"] set t [textblock::class::table new -minwidth 80 -show_seps 0] foreach row $cmdinfo { @@ -8046,9 +8048,9 @@ namespace eval punk { set title "[a+ brightgreen] Namespace navigation: " set cmdinfo [list] lappend cmdinfo [list n/ "?${I}ns${NI}|${I}glob${NI}?" "view/change namespace\n (accepts ns path globs e.g **::*get* to match\n commands at any level )"] - lappend cmdinfo [list n// "?${I}ns${NI}|${I}glob${NI}?" "view/change namespace (with command listing)"] - lappend cmdinfo [list "nn/" "" "go up one namespace"] - lappend cmdinfo [list "n/new" "${I}ns${NI}" "make child namespace and switch to it"] + lappend cmdinfo [list n// "?${I}ns${NI}|${I}glob${NI}?" "view/change namespace (with command listing)"] + lappend cmdinfo [list "nn/" "" "go up one namespace"] + lappend cmdinfo [list "newns" "${I}ns${NI}" "make child namespace and switch to it"] set t [textblock::class::table new -minwidth 80 -show_seps 0] foreach row $cmdinfo { $t add_row $row @@ -8236,104 +8238,110 @@ namespace eval punk { lappend chunks [list stdout $text] } console - term - terminal { - set indent [string repeat " " [string length "WARNING: "]] - lappend cstring_tests [dict create\ - type "PM "\ - msg "UN"\ - f7 punk::ansi::controlstring_PM\ - f7prefix "7bit ESC ^ secret "\ - f7suffix "safe"\ - f8 punk::ansi::controlstring_PM8\ - f8prefix "8bit \\x9e secret "\ - f8suffix "safe"\ - ] - lappend cstring_tests [dict create\ - type SOS\ - msg "NOT"\ - f7 punk::ansi::controlstring_SOS\ - f7prefix "7bit ESC X string "\ - f7suffix " hidden"\ - f8 punk::ansi::controlstring_SOS8\ - f8prefix "8bit \\x98 string "\ - f8suffix " hidden"\ - ] - lappend cstring_tests [dict create\ - type APC\ - msg "NOT"\ - f7 punk::ansi::controlstring_APC\ - f7prefix "7bit ESC _ APPLICATION PROGRAM COMMAND "\ - f7suffix " hidden"\ - f8 punk::ansi::controlstring_APC8\ - f8prefix "8bit \\x9f APPLICATION PROGRAM COMMAND "\ - f8suffix " hidden"\ - ] + if {[catch {package require punk::console} result]} { + set text "Unable to load punk::console package - cannot test\n$result" + lappend chunks [list stdout $text] + } else { - foreach test $cstring_tests { - set m [[dict get $test f7] [dict get $test msg]] - set hidden_width_m [punk::console::test_char_width $m] - set m8 [[dict get $test f8] [dict get $test msg]] - set hidden_width_m8 [punk::console::test_char_width $m8] - if {$hidden_width_m != 0 || $hidden_width_m8 != 0} { - if {$hidden_width_m == 0} { - set d "[a+ green bold][dict get $test f7prefix][a red]${m}[a][a+ green bold][dict get $test f7suffix][a]" - } else { - set d "[a+ yellow bold][dict get $test f7prefix][a red]$m[a][a+ yellow bold][dict get $test f7suffix][a]" - } - if {$hidden_width_m8 == 0} { - set d8 "[a+ green ][dict get $test f8prefix][a red]$m8[a][a+ green][dict get $test f8suffix][a]" - } else { - set d8 "[a+ yellow bold][dict get $test f8prefix][a red]$m8[a][a+ yellow bold][dict get $test f8suffix][a]" + set indent [string repeat " " [string length "WARNING: "]] + lappend cstring_tests [dict create\ + type "PM "\ + msg "UN"\ + f7 punk::ansi::controlstring_PM\ + f7prefix "7bit ESC ^ secret "\ + f7suffix "safe"\ + f8 punk::ansi::controlstring_PM8\ + f8prefix "8bit \\x9e secret "\ + f8suffix "safe"\ + ] + lappend cstring_tests [dict create\ + type SOS\ + msg "NOT"\ + f7 punk::ansi::controlstring_SOS\ + f7prefix "7bit ESC X string "\ + f7suffix " hidden"\ + f8 punk::ansi::controlstring_SOS8\ + f8prefix "8bit \\x98 string "\ + f8suffix " hidden"\ + ] + lappend cstring_tests [dict create\ + type APC\ + msg "NOT"\ + f7 punk::ansi::controlstring_APC\ + f7prefix "7bit ESC _ APPLICATION PROGRAM COMMAND "\ + f7suffix " hidden"\ + f8 punk::ansi::controlstring_APC8\ + f8prefix "8bit \\x9f APPLICATION PROGRAM COMMAND "\ + f8suffix " hidden"\ + ] + + foreach test $cstring_tests { + set m [[dict get $test f7] [dict get $test msg]] + set hidden_width_m [punk::console::test_char_width $m] + set m8 [[dict get $test f8] [dict get $test msg]] + set hidden_width_m8 [punk::console::test_char_width $m8] + if {$hidden_width_m != 0 || $hidden_width_m8 != 0} { + if {$hidden_width_m == 0} { + set d "[a+ green bold][dict get $test f7prefix][a red]${m}[a][a+ green bold][dict get $test f7suffix][a]" + } else { + set d "[a+ yellow bold][dict get $test f7prefix][a red]$m[a][a+ yellow bold][dict get $test f7suffix][a]" + } + if {$hidden_width_m8 == 0} { + set d8 "[a+ green ][dict get $test f8prefix][a red]$m8[a][a+ green][dict get $test f8suffix][a]" + } else { + set d8 "[a+ yellow bold][dict get $test f8prefix][a red]$m8[a][a+ yellow bold][dict get $test f8suffix][a]" + } + append warningblock \n "WARNING: terminal doesn't hide all [dict get $test type] control strings: $d $d8" } - append warningblock \n "WARNING: terminal doesn't hide all [dict get $test type] control strings: $d $d8" } - } - if {![catch {punk::console::check::has_bug_legacysymbolwidth} result]} { - if {$result} { - append warningblock \n "WARNING: terminal has legacysymbolwidth bug - screen position for symbol reports 2 wide but displays 1 wide." - append warningblock \n $indent "Layout using 'legacy symbols for computing' affected." - append warningblock \n $indent "(e.g textblock frametype block2 unsupported)" - append warningblock \n $indent "This can cause extreme layout deformation when ANSI is present" - append warningblock \n $indent "In some cases unwanted spacing effects occur at a distance from the characters causing it" + if {![catch {punk::console::check::has_bug_legacysymbolwidth} result]} { + if {$result} { + append warningblock \n "WARNING: terminal has legacysymbolwidth bug - screen position for symbol reports 2 wide but displays 1 wide." + append warningblock \n $indent "Layout using 'legacy symbols for computing' affected." + append warningblock \n $indent "(e.g textblock frametype block2 unsupported)" + append warningblock \n $indent "This can cause extreme layout deformation when ANSI is present" + append warningblock \n $indent "In some cases unwanted spacing effects occur at a distance from the characters causing it" + } + } else { + append warningblock \n "WARNING: terminal unable to check for legacysymbolwidth bug. err:$result" } - } else { - append warningblock \n "WARNING: terminal unable to check for legacysymbolwidth bug. err:$result" - } - if {![catch {punk::console::check::has_bug_zwsp} result]} { - if {$result} { - append warningblock \n "WARNING: terminal has zero width space (\\u200b) bug - cursor position incremented when it shouldn't be." - append warningblock \n $indent "The zwsp may or may not be displayed. zwsp contributes to line length and wrapping point" + if {![catch {punk::console::check::has_bug_zwsp} result]} { + if {$result} { + append warningblock \n "WARNING: terminal has zero width space (\\u200b) bug - cursor position incremented when it shouldn't be." + append warningblock \n $indent "The zwsp may or may not be displayed. zwsp contributes to line length and wrapping point" + } + } else { + append warningblock \n "WARNING: terminal unable to check for zwsp bug. err:$result" } - } else { - append warningblock \n "WARNING: terminal unable to check for zwsp bug. err:$result" - } - set grapheme_support [punk::console::grapheme_cluster_support] - #mode, 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) - if {![dict size $grapheme_support] || [dict get $grapheme_support mode] eq "unsupported" } { - append warningblock \n "WARNING: terminal either doesn't support grapheme clusters, or doesn't report so via decmode 2027 query." - if {[dict size $grapheme_support] && [dict get $grapheme_support available]} { - append warningblock \n $indent "(but punk::console::grapheme_cluster_support has determined it is probably available)" - } - } else { - if {![dict get $grapheme_support available]} { - switch -- [dict get $grapheme_support mode] { - "unset" { - append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is off." - } - "permanently_unset" { - append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is permanently off." - } - "BAD_RESPONSE" { - append warningblock \n "WARNING: terminal doesn't seem to recognize decmode 2027 query. No grapheme cluster support." + set grapheme_support [punk::console::grapheme_cluster_support] + #mode, 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) + if {![dict size $grapheme_support] || [dict get $grapheme_support mode] eq "unsupported" } { + append warningblock \n "WARNING: terminal either doesn't support grapheme clusters, or doesn't report so via decmode 2027 query." + if {[dict size $grapheme_support] && [dict get $grapheme_support available]} { + append warningblock \n $indent "(but punk::console::grapheme_cluster_support has determined it is probably available)" + } + } else { + if {![dict get $grapheme_support available]} { + switch -- [dict get $grapheme_support mode] { + "unset" { + append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is off." + } + "permanently_unset" { + append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is permanently off." + } + "BAD_RESPONSE" { + append warningblock \n "WARNING: terminal doesn't seem to recognize decmode 2027 query. No grapheme cluster support." + } } } } - } - if {![string length $warningblock]} { - set text "No terminal warnings\n" - lappend chunks [list stdout $text] + if {![string length $warningblock]} { + set text "No terminal warnings\n" + lappend chunks [list stdout $text] + } } } topics - help { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm index fb5adce3..8450b2c8 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm @@ -108,7 +108,7 @@ tcl::namespace::eval punk::aliascore { # the aliascore::init will temporarily extend the exports list to do the import, and then reset the exports to how they were. set aliases [tcl::dict::create\ val ::punk::pipe::val\ - tstr ::punk::lib::tstr\ + tstr ::punk::args::lib::tstr\ list_as_lines ::punk::lib::list_as_lines\ lines_as_list ::punk::lib::lines_as_list\ linelist ::punk::lib::linelist\ @@ -116,7 +116,7 @@ tcl::namespace::eval punk::aliascore { pdict ::punk::lib::pdict\ plist {::punk::lib::pdict -roottype list}\ showlist {::punk::lib::showdict -roottype list}\ - rehash ::punk::rehash\ + rehash ::punk::auto_exec::rehash\ showdict ::punk::lib::showdict\ ansistrip ::punk::ansi::ansistrip\ stripansi ::punk::ansi::ansistrip\ @@ -228,7 +228,7 @@ tcl::namespace::eval punk::aliascore { } } if {!$opt_force && [llength $conflicts]} { - error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts" + error "punk::aliascore::init declined to create any aliases or imports because conflicts found. Use -force == 1 conflicts:\n [join $conflicts "\n "]" } set failed [list] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm index 5abc839d..cb6f796b 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm @@ -273,21 +273,68 @@ tcl::namespace::eval ::punk::args {} tcl::namespace::eval ::punk::args::helpers { variable PUNKARGS namespace export * - #proc B {} {return \x1b\[1m} ;#a+ bold - #proc N {} {return \x1b\[22m} ;#a+ normal - #proc I {} {return \x1b\[3m} ;#a+ italic - #proc NI {} {return \x1b\[23m} ;#a+ noitalic - proc I {} {punk::ansi::a+ italic} - proc B {} {punk::ansi::a+ bold} - proc N {} {punk::ansi::a+ normal} - proc NI {} {punk::ansi::a+ italic} + proc B {} {return \x1b\[1m} ;#a+ bold + proc N {} {return \x1b\[22m} ;#a+ normal + proc I {} {return \x1b\[3m} ;#a+ italic + proc NI {} {return \x1b\[23m} ;#a+ noitalic + #proc I {} {punk::ansi::a+ italic} + #proc B {} {punk::ansi::a+ bold} + #proc N {} {punk::ansi::a+ normal} + #proc NI {} {punk::ansi::a+ italic} lappend PUNKARGS [list { @id -id ::punk::args::helpers::example @cmd -name punk::args::helpers::example\ -summary\ {Display formatting for argdoc example text}\ -help\ - {Wrap } + {Wrap a block of text (e.g tcl code) in a box with optional syntax highlighting and title. + The text is processed with punk::lib::tstr to allow for command substitution and basic formatting, + but without any further dedenting (i.e it's assumed the text is already dedented appropriately + based on context). + The example function is intended for use in punk::args::define scripts to format example text in + the generated documentation, but it can be used in other contexts too. + + The box is a plain grey background with a lighter grey top and bottom border. + There are no side borders so the text can be copied without extra characters getting in the way, + These top and bottom bars are implemented using unicode block characters so the bars are still + visible when ANSI is stripped. + + ${[punk::args::helpers::example -title "[a+ term-yellow Term-blue] Example 1 [a]" { + #A sample of an example block of text with a garish title and some basic tcl syntax highlighting. + + proc test {args} { + puts "[a+ red]hello world[a]" + } + + }]} + + This was generated with code like the following in the punk::args::define script: + + ${[punk::args::helpers::example -syntax none -tstr 1 { + + ${[example -title "[a+ term-yellow Term-blue] Example 1 [a]" { + #A sample of an example block of text with a garish title and some basic tcl syntax highlighting. + + proc test {args} { + puts "[a+ red]hello world[a]" + } + + }]} + + }]} + + Here we eat our own dog food by nesting the example text within an ${[B]}example${[N]} call with -tstr 0 + to prevent the tstr processing of the text, and -syntax none to prevent the syntax highlighting. + This allows us to show the actual code used to generate ${[a+ term-yellow Term-blue]} Example 1 ${[a+ defaultbg][a]} above without having to use any + escaping backslashes etc that may show in the output. + + Note the slight indent of 2 characters on the left of the text in the example block. + This is intentional to show that the text is indented within the box, and as it's reasonably appealing + visually, explains why the -padright option defaults to padding with 2 chars on the right of the text. + + see also ${[B]}punk::args::lib::tstr${[N]} + + } @opts -padright -type integer -default 2 -help\ {Number of padding spaces to add on RHS of text block} @@ -295,9 +342,24 @@ tcl::namespace::eval ::punk::args::helpers { tcl\ " Very basic tcl syntax highlighting of braces,square brackets and comments." - -title -type string -default "" + } + -title -type string -default "" -help\ + {Optional title to display in the top border of the box. + The title is overlaid on the top bar which consists of lower-half block characters. + These block characters are set with foreground black and background silver, so the lower portion + of the bar appears silver. When the title is overlaid on top of this it gets the same colouring + so that the result is black text on siver background, but full height for the width of the title text. + + The title colour can be set to something other than the default black on silver by including ANSI in + the title text, but the bar on either side will still be silver. + e.g -title "[a+ term-yellow Term-blue]yellow on blue title[a]" + } + -tstr -type boolean -default 1 -help\ + {By setting this to false, we can disable tstr processing of the text. This means that the text will be + treated as a literal string and any tstr variable or command substitution will not be processed. + This can be useful if you want to include text that contains tstr formatting characters or commands + without them being interpreted.} -titlealign -type string -choices {left centre right} - } text -type string }] proc example {args} { @@ -317,10 +379,11 @@ tcl::namespace::eval ::punk::args::helpers { -syntax tcl\ -title ""\ -titlealign left\ + -tstr 1\ ] dict for {o v} $optlist { switch -- $o { - -padright - -syntax - -title - -titlealign {} + -padright - -syntax - -title - -titlealign - -notstr {} default { punk::args::parse $args withid ::punk::args::helpers::example return @@ -332,6 +395,7 @@ tcl::namespace::eval ::punk::args::helpers { set opt_syntax [dict get $opts -syntax] set opt_title [dict get $opts -title] set opt_titlealign [dict get $opts -titlealign] + set opt_tstr [dict get $opts -tstr] if {[string index $str 0] eq "\n"} { set str [string range $str 1 end] @@ -341,7 +405,10 @@ tcl::namespace::eval ::punk::args::helpers { } #example is intended to run from a source doc that has already been dedented appropriately based on context # - we don't want to further undent, hence -undent 0 - set str [uplevel 1 [list punk::lib::tstr -undent 0 -return string -eval 1 -allowcommands $str]] + if {$opt_tstr} { + #this is the default + set str [uplevel 1 [list punk::lib::tstr -undent 0 -return string -eval 1 -allowcommands $str]] + } #puts stderr ------------------- #puts $str #puts stderr ------------------- @@ -752,6 +819,10 @@ tcl::namespace::eval punk::args { argument name - only applies to final leader OR final value) (for options/flags this allows the opt-val pair or solo flag to appear multiple times - not necessarily contiguously) + -multipleunique (only valid if -multiple is true) + If true, when multiple values are stored against the same argument + name due to -multiple being true, the values must be unique. + If false, the same value can be stored multiple times. -choices {} A list of allowable values for an argument. The -default value doesn't have to be in the list. @@ -809,6 +880,24 @@ tcl::namespace::eval punk::args { If allows more than one choice the value is a list consisting of items in the choices made available through entries in -choices/-choicegroups. + -choicemultipleunique (default 0) + If choicemultiple is set to allow more than one choice, this + option specifies whether the choices must be unique within the + value list. If true, the same choice can't be selected more than + once. If false, the same choice can be selected multiple times. + -choicemultipleuniqueset (default 0) + Only applies if -choicemultiple is true and -multiple is true. + If choicemultiple is set to allow more than one choice, and + -multiple is true, this option specifies whether the sets of + choices must be unique across multiple occurrences of the argument. + If true, the same set of choices can't be selected more than once + across multiple occurrences of the multi-choice argument. + If false, the same set of choices can be selected multiple times + across multiple occurrences of the argument. + Without this option being set true, if -multiple is true and + -multipleunique is true, then the same set of choices in a + different order would be considered unique, which may not be + desirable. -unindentedfields {} for fields with multi-line values, tell the resolver to treat them as unindented. ie do no indent/unindent processing of @@ -902,8 +991,11 @@ tcl::namespace::eval punk::args { -choiceprefix 1\ -choicerestricted 1\ -choicemultiple {1 1}\ + -choicemultipleunique 0\ + -choicemultipleuniqueset 0\ -unindentedfields {}\ -multiple 0\ + -multipleunique 0\ -regexprepass {}\ -validationtransform {}\ -ensembleparameter 0\ @@ -918,8 +1010,11 @@ tcl::namespace::eval punk::args { -choiceprefix 1\ -choicerestricted 1\ -choicemultiple {1 1}\ + -choicemultipleunique 0\ + -choicemultipleuniqueset 0\ -unindentedfields {}\ -multiple 0\ + -multipleunique 0\ -regexprepass {}\ -validationtransform {}\ -prefix 1\ @@ -938,8 +1033,11 @@ tcl::namespace::eval punk::args { -choiceprefix 1\ -choicerestricted 1\ -choicemultiple {1 1}\ + -choicemultipleunique 0\ + -choicemultipleuniqueset 0\ -unindentedfields {}\ -multiple 0\ + -multipleunique 0\ -regexprepass {}\ -validationtransform {}\ ] @@ -1718,7 +1816,8 @@ tcl::namespace::eval punk::args { } -unindentedfields - -minsize - -maxsize - - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - + -choices - -choicegroups - -choicemultiple - + -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted { #review - only apply to certain types? tcl::dict::set tmp_optspec_defaults $k $v @@ -1807,7 +1906,8 @@ tcl::namespace::eval punk::args { -allow_ansi - -validate_ansistripped - -strip_ansi - - -multiple - + -multiple - -multipleunique - + -choicemultipleunique - -choicemultipleuniqueset - -prefix { #check is bool if {![string is boolean -strict $v]} { @@ -1823,6 +1923,7 @@ tcl::namespace::eval punk::args { -unindentedfields\ -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple -prefix\ + -multipleunique -choicemultipleunique -choicemultipleuniqueset\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ } error "punk::args::resolve - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" @@ -1936,7 +2037,10 @@ tcl::namespace::eval punk::args { -allow_ansi - -validate_ansistripped - -strip_ansi - - -multiple { + -multiple - + -multipleunique - + -choicemultipleunique - -choicemultipleuniqueset - + -optional { if {![string is boolean -strict $v]} { error "punk::args::resolve - invalid type of value '$v' for key '$k' in @leaders line. Must be boolean @id:$DEF_definition_id" } @@ -1961,6 +2065,7 @@ tcl::namespace::eval punk::args { -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ -unindentedfields\ -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -multipleunique -choicemultipleunique -choicemultipleuniqueset\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ -unnamed\ } @@ -2051,11 +2156,13 @@ tcl::namespace::eval punk::args { -typeranges { tcl::dict::set tmp_valspec_defaults -typeranges $v } - -optional - -allow_ansi - -validate_ansistripped - -strip_ansi - - -multiple { + -multiple - + -multipleunique - + -choicemultipleunique - -choicemultipleuniqueset - + -optional { if {![string is boolean -strict $v]} { error "punk::args::resolve - invalid type of value '$v' for key '$k' in @values line. Must be boolean @id:$DEF_definition_id" } @@ -2083,6 +2190,7 @@ tcl::namespace::eval punk::args { -unindentedfields\ -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -multipleunique -choicemultipleunique -choicemultipleuniqueset\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ -unnamed\ } @@ -2414,6 +2522,7 @@ tcl::namespace::eval punk::args { -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted - -choicelabels - -choiceinfo - -minsize - -maxsize - -nocase - -multiple - + -multipleunique - -choicemultipleunique - -choicemultipleuniqueset - -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - -regexprepass - -regexprefail - -regexprefailmsg { @@ -2519,6 +2628,7 @@ tcl::namespace::eval punk::args { -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted\ -unindentedfields\ -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -multipleunique -choicemultipleunique -choicemultipleuniqueset\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ -ensembleparameter\ ] @@ -9228,7 +9338,7 @@ tcl::namespace::eval punk::args { set v_test $c_check } set choice_in_list 0 - set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? + set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval could be a list when -choicemultiple? if {!$matches_default} { if {$choiceprefix} { #can we handle empty string as a choice? It should just work - REVIEW/test @@ -9277,6 +9387,7 @@ tcl::namespace::eval punk::args { set chosen $bestmatch set choice_in_list 1 } + puts ">>>>> chosen: $chosen bestmatch: $bestmatch for c_check: $c_check choices_test: $choices_test allchoices: $allchoices" } else { set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check] if {$chosen eq "" || $chosen in $choiceprefixreservelist} { @@ -9302,9 +9413,11 @@ tcl::namespace::eval punk::args { if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { #single choice allowed per clause-member if {$is_multiple} { + puts ">>>>> existing:'$existing' element_index:$element_index choice_index:$choice_idx chosen: $chosen" if {$clause_size == 1} { #no list wrapping of single element in $dname dict - so don't index into it with element_index - lset existing $element_index $chosen + #lset existing $element_index $chosen ;#wrong - test::punk::args test: choice_multiple_with_choiceprefix. + lset existing $clause_index $chosen } else { lset existing $clause_index $element_index $chosen } @@ -10626,10 +10739,29 @@ tcl::namespace::eval punk::args::lib { Placeholder Substitutions: \$\{$varName\} \$\{[myCommand]\} - (when -allowcommands flag is given)" + (myCommand is evaluated when -allowcommands flag is given) + + If any error occurs during placeholder evaluation, the original placeholder text + is substituted in the output and the error is included in the returned dict + (if -return dict is used). + " -allowcommands -default 0 -type none -help\ - "If -allowcommands is present, placeholder can contain commands - e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" + "If -allowcommands is present, placeholder commands are evaluated and subtituted. + e.g tstr -allowcommands { \$\{plaintext0 [lindex $var 1] plaintext2\} } + + if $var is {a b c}, the result will be \"plaintext0 b plaintext2 \" + if $var does not exist the result will be \"\$\{plaintext0 [lindex $var 1] plaintext2\} \" + with an error recorded in the returned dict if -return dict is used. + + NOTE: even if -allowcommands is not present, the placeholder text is still processed for variable + substitution and escape sequence processing, so the result will not be the raw placeholder text. + The result will be \"plaintext0 [lindex {a b c} 0] plaintext2 \" + + e.g + tstr -undent 0 -allowcommands { \$\{ \\$var\\[1\\] = [lindex $var 1]\}} + $var[1] = b + " + -undent -default 1 -type boolean -help\ "undent/dedent the template lines. The longest common prefix of whitespace is removed" @@ -10702,6 +10834,14 @@ tcl::namespace::eval punk::args::lib { which expects the placeholders as individual arguments" } + -raise_errors -default 0 -type boolean -help\ + "By default, if an error occurs during placeholder evaluation, the original placeholder text + is substituted in the output and the error is included in the returned dict (if -return dict is used). + If -raise_errors is set to 1, the template will be processed and a list of errors will be collected as + normal, but if any errors are present at the end of processing, a single error will be raised with a + summary of all errors that occurred. + This can be useful for debugging or when you want to ensure that any issues with placeholder evaluation + are immediately visible and not silently included in the output." -eval -default 1 -type boolean -help\ "Whether to evaluate the \$\{\} placeholders. When -return is string, -eval should generally be set to 1. @@ -10739,6 +10879,7 @@ tcl::namespace::eval punk::args::lib { -paramindents line\ -eval 1\ -return string\ + -raise_errors 0\ ] if {"-allowcommands" in $arglist} { set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] @@ -10754,9 +10895,9 @@ tcl::namespace::eval punk::args::lib { } } dict for {k v} $arglist { - set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] + set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval -raise_errors} $k] switch -- $fullk { - -indent - -undent - -paramindents - -return - -eval { + -indent - -undent - -paramindents - -return - -eval - -raise_errors { dict set opts $fullk $v } default { @@ -10781,6 +10922,7 @@ tcl::namespace::eval punk::args::lib { set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] if {$opt_return eq ""} { } + set opt_raise_errors [dict get $opts -raise_errors] set opt_eval [dict get $opts -eval] @@ -10871,6 +11013,14 @@ tcl::namespace::eval punk::args::lib { incr idx ;#expression incr } + if {$opt_raise_errors && [dict size $errors]} { + set einfo "" + dict for {i e} $errors { + append einfo "parameter $i error: $e" \n + } + error "punk::args::lib::tstr: Errors occurred during placeholder evaluation:\n$einfo" + } + if {$opt_return eq "dict"} { return [dict create template $textchunks params $params errors $errors] } @@ -11200,17 +11350,39 @@ tcl::namespace::eval punk::args::package { set pkgname [${pkgns}::package_name] set opt_return [dict get $OPTS -return] - set all_topics [${pkgns}::about_topics] + set defined_topics [${pkgns}::about_topics] if {![dict exists $received topic]} { - set topics $all_topics + set topics $defined_topics } else { # * represents all remaining topics not explicitly mentioned. set val_topics [dict get $values topic] ;#if -multiple is true, this is a list - set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] + #set explicit_topic_prefixes [lsearch -all -inline -exact -not $val_topics "*"] + set explicit_topics [list] + set requested_topics [list] + set defined_topics_lc [lmap t $defined_topics {string tolower $t}] + foreach et $val_topics { + #topics are case insensitive. We don't expect function names from about_topics to have variations differing only in case. + #todo - enforce this by only returning the last value from about_topics for each particular topic when there are duplicates differing only in case. + #(see punk::auto_execs for example. TODO -add to template or use helper function to enforce this when processing about_topics) + if {$et eq "*"} { + lappend requested_topics "*" + continue + } + + set fulltopic_lc [tcl::prefix::match -error "" $defined_topics_lc [string tolower $et]] + if {$fulltopic_lc eq ""} { + error "punk::args::package::standard_about topic '$et' does not match any defined topics: $defined_topics" + } else { + set resolved_topic [lsearch -inline -nocase $defined_topics $fulltopic_lc] + lappend explicit_topics $resolved_topic + lappend requested_topics $resolved_topic + } + } + set topics [list] - foreach t $val_topics { + foreach t $requested_topics { if {$t eq "*"} { - foreach a $all_topics { + foreach a $defined_topics { if {$a ni $explicit_topics} { lappend topics $a } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/auto_exec-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/auto_exec-0.1.0.tm index 22486038..662656cb 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/auto_exec-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/auto_exec-0.1.0.tm @@ -47,6 +47,45 @@ tcl::namespace::eval punk::auto_exec { set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline] } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id "::punk::auto_exec::rehash" + @cmd -name "punk::auto_exec::rehash"\ + -summary\ + "Update the hash table of autoexec commands cached in ::auto_execs."\ + -help\ + {Clear/refresh the autoexec commands in the ::auto_execs array. + + This is analogous to the 'rehash' command in shells such as csh, tcsh and zsh. + It updates the shell's hash table of executable commands. + + This can be useful after installing new software, adjusting the environment PATH directories, or (on windows) making + changes to the system that may affect file type associations and their associated commands, to ensure that the autoexec + commands are up to date with the current state of the system. + + If refresh is false (the default), then all autoexec commands are cleared and will re-register as commands are called. + If refresh is true, then all existing autoexec commands are re-registered by calling auto_execok for each of them again.} + @opts + @values -min 0 -max 1 + refresh -type boolean -default 0 -help\ + "Whether to re-register existing autoexec commands by calling auto_execok for each of them again." + }] + } + proc rehash {{refresh 0}} { + global auto_execs + if {!$refresh} { + unset -nocomplain auto_execs + } else { + set names [array names auto_execs] + unset -nocomplain auto_execs + foreach nm $names { + #auto_execok_windows $nm + auto_execok $nm + } + } + return + } + variable PUNKARGS lappend PUNKARGS [list { @id -id "::punk::auto_exec::shell_open_command" @@ -347,7 +386,7 @@ tcl::namespace::eval punk::auto_exec { if {!$new_chunk} { if {$current_chunk ne "" || $current_chunk eq "" && [lindex $quoted end]} { - #we add the current chunk to the result list if it's not empty, or if it is empty but is quoted (because in that case we want to preserve it as an empty argument). + #we add the current chunk to the result list if it's not empty, or if it is empty but is quoted (because in that case we want to preserve it as an empty argument). lappend result $current_chunk lappend quoted 0 set current_chunk {} @@ -564,15 +603,17 @@ tcl::namespace::eval punk::auto_exec { user-specific association is found. Returns a dict of dicts with toplevel keys for each shell verb (e.g open, runas) and values that are dicts with keys - ${$I}type${$NI} and ${$I}value${$NI} and ${$I}scope${$NI}, where - type is determined from the registry value type (e.g sz or expand_sz) - string is the raw command string from the registry - scope is either "user" or "system" depending on whether the value was found in the user-specific registry keys or - the system registry keys. + ${$I}type${$NI} and ${$I}value${$NI} and ${$I}scope${$NI}, where: + + ${$I}type${$NI} is determined from the registry value type (e.g sz or expand_sz) + + ${$I}string${$NI} is the raw command string from the registry + + ${$I}scope${$NI} is either \"user\" or \"system\" depending on whether the value was found in the user-specific + registry keys or the system registry keys. This is somewhat like the windows 'ftype' command except that the windows command only looks for the 'open' verb and - only looks up the system association and does not take into account any user-specific - overrides. + only looks up the system association and does not take into account any user-specific overrides. The file type can be looked up using the ${$B}assoc${$N} function in this package. @@ -587,40 +628,11 @@ tcl::namespace::eval punk::auto_exec { This can be looked up using the 'assoc' function in this package." }] } - #proc ftype {filetype} { - # package require registry - - # if {$filetype eq "cplfile"} { - # #special case for cplfile (associated with .cpl files) which doesn't follow the usual pattern of having the command string under shell\open\command, - # #but instead has it under HKEY_LOCAL_MACHINE\SOFTWARE\Classes\cplfile\shell\cplopen\command. - # #There doesn't seem to be any user-specific override for this file type - # #- but we will check for one under HKEY_CURRENT_USER\Software\Classes\cplfile\shell\cplopen\command anyway for consistency with the way we check - # #for user-specific overrides for other file types. - # set key [join [list HKEY_CURRENT_USER Software Classes cplfile shell cplopen command] "\\"] - # } else { - # set key [join [list HKEY_CURRENT_USER Software Classes $filetype shell open command] "\\"] - # } - # if {![catch {registry get $key ""} raw_assoc]} { - # set tp [registry type $key ""] - # return [dict create open [dict create type $tp string $raw_assoc]] - # } else { - # #e.g Python.File - # if {$filetype eq "cplfile"} { - # set key [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes cplfile shell cplopen command] "\\"] - # } else { - # set key [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $filetype shell open command] "\\"] - # } - # if {![catch {registry get $key ""} raw_assoc]} { - # set tp [registry type $key ""] - # return [dict create type $tp string $raw_assoc] - # } else { - # return [dict create type "" string ""] ;#no association found - # } - # } - #} proc ftype {filetype} { package require registry set resultdict [dict create] + #registry queries are case insensitive but some are keys are cased differently e.g Open vs open. + #when using the verb as a key in the output dict, we need to normalize so that it is useful for lookups. We'll use lowercase for that. #e.g Python.File set shellpath [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $filetype shell] "\\"] @@ -628,8 +640,6 @@ tcl::namespace::eval punk::auto_exec { foreach verb $shellverbs { set commandkey [join [list $shellpath $verb command] "\\"] if {![catch {registry get $commandkey ""} cmdstring]} { - #registry queryies are case insensitive but some are cased differently e.g Open vs open. - #when using the verb as a key in the output dict, we need to normalize so that it is useful for lookups. We'll use lowercase for that. set verb [string tolower $verb] set tp [registry type $commandkey ""] dict set resultdict $verb [dict create type $tp value $cmdstring scope system] @@ -649,7 +659,6 @@ tcl::namespace::eval punk::auto_exec { } } } - return $resultdict } @@ -671,9 +680,9 @@ tcl::namespace::eval punk::auto_exec::lib { #} -# == === === === === === === === === === === === === === === +# == === === === === === === === === === === === === === === # Sample 'about' function with punk::args documentation -# == === === === === === === === === === === === === === === +# == === === === === === === === === === === === === === === tcl::namespace::eval punk::auto_exec { tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase variable PUNKARGS @@ -682,8 +691,7 @@ tcl::namespace::eval punk::auto_exec { lappend PUNKARGS [list { @id -id "(package)punk::auto_exec" @package -name "punk::auto_exec" -help\ - "Package - Description" + "An autoexec_ok replacement for Tcl with support for windows file type associations and command string parsing." }] namespace eval argdoc { @@ -695,26 +703,34 @@ tcl::namespace::eval punk::auto_exec { #info commands results are returned in an arbitrary order (like array keys) set topic_funs [info commands [namespace current]::get_topic_*] set about_topics [list] + #use a dict to enforce last case-variation of a topic wins. + set case_dict [dict create] foreach f $topic_funs { set tail [namespace tail $f] - lappend about_topics [string range $tail [string length get_topic_] end] + set t [string range $tail [string length get_topic_] end] + set t_lc [string tolower $tail] + dict set case_dict $t_lc $t + } + dict for {lc t} $case_dict { + lappend about_topics $t } + #Adjust this function or 'default_topics' if a different order is required return [lsort $about_topics] } proc default_topics {} {return [list Description *]} # ------------------------------------------------------------- - # get_topic_ functions add more to auto-include in about topics + # get_topic_ functions add more to auto-include in about topics # ------------------------------------------------------------- proc get_topic_Description {} { - punk::args::lib::tstr [string trim { - package punk::auto_exec - description to come.. + punk::args::lib::tstr [string trim { + package punk::auto_exec + A replacement for Tcl's builtin autoexec_ok function. } \n] } proc get_topic_License {} { - return "" + return "BSD-3-Clause" } proc get_topic_Version {} { return "$::punk::auto_exec::version" @@ -730,22 +746,41 @@ tcl::namespace::eval punk::auto_exec { } return $contributors } - proc get_topic_custom-topic {} { - punk::args::lib::tstr -return string { - A custom - topic - etc - } + proc get_topic_Notes {} { + return [string trim { + This package primarily provides advanced features on the windows platform, but some functions such as 'rehash' are + useful on any platform. + + This package provides functions to look up windows file type associations and to parse command strings with placeholders + and environment variables, which can be used as a replacement for Tcl's autoexec_ok function in certain contexts. + + The 'assoc' function looks up the associated file type for a given file extension, taking into account both user-specific + and system-wide associations in the registry. + + The 'ftype' function looks up the shell verb command values for a given file type, also taking into account both user-specific + and system-wide associations in the registry. + + The 'shell_command_as_tcl_list' function processes a command string with placeholders and environment variables and returns a + Tcl list of command and arguments with the placeholders substituted according to the specified rules. + + } \n] } + #proc get_topic_custom-topic {} { + # punk::args::lib::tstr -return string { + # A custom + # topic + # etc + # } + #} # ------------------------------------------------------------- } # we re-use the argument definition from punk::args::standard_about and override some items set overrides [dict create] dict set overrides @id -id "::punk::auto_exec::about" - dict set overrides @cmd -name "punk::auto_exec::about" + dict set overrides @cmd -name "punk::auto_exec::about" dict set overrides @cmd -help [string trim [punk::args::lib::tstr { - About punk::auto_exec + About punk::auto_exec }] \n] dict set overrides topic -choices [list {*}[punk::auto_exec::argdoc::about_topics] *] dict set overrides topic -choicerestricted 1 @@ -761,7 +796,7 @@ tcl::namespace::eval punk::auto_exec { } } # end of sample 'about' function -# == === === === === === === === === === === === === === === +# == === === === === === === === === === === === === === === # ----------------------------------------------------------------------------- @@ -776,11 +811,11 @@ namespace eval ::punk::args::register { # ----------------------------------------------------------------------------- # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::auto_exec [tcl::namespace::eval punk::auto_exec { variable pkg punk::auto_exec variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm index 8d5a5dca..3d967541 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm @@ -15,13 +15,16 @@ tcl::namespace::eval punk::config { namespace eval punk {namespace export config} proc _homedir {} { - if {[info exists ::env(HOME)]} { - set home [file normalize $::env(HOME)] - } else { - #not available on 8.6? ok will error out here. - set home [file tildeexpand ~] - } - return $home + return [punk::nav::fs::~] ;#will work if HOME is not set. + #may return an error if no home directory can be determined + + #if {[info exists ::env(HOME)]} { + # set home [file normalize $::env(HOME)] + #} else { + # #not available on 8.6? ok will error out here. + # set home [file tildeexpand ~] + #} + #return $home } lappend PUNKARGS [list { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/du-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/du-0.1.0.tm index 6d2eb59f..ad27135d 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/du-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/du-0.1.0.tm @@ -1712,7 +1712,7 @@ namespace eval punk::du { set errors [dict create] foreach {k v} $args { switch -- $k { - -glob - -with_sizes - -with_times { + -glob - -filedebug - -patterndebug - -link_info - -with_sizes - -with_times - -types { dict set opts $k $v } default { @@ -1766,6 +1766,7 @@ namespace eval punk::du { set types_entry [list] set types_attribute [list] set types_permission [list] + set types_REQUIRED [list] foreach t $entry_and_attribute_types { switch -- $t { f - d - l - p - s - b - c { @@ -1775,16 +1776,46 @@ namespace eval punk::du { hidden - readonly { #these are all valid attributes lappend types_attribute $t + lappend types_REQUIRED $t } r - w - x { #these are all valid permissions lappend types_permission $t + lappend types_REQUIRED $t } default { error "du_dirlisting_generic unrecognized element in -types '$t'. Known types/attributes/permissions: f d l p s b c hidden readonly r w x" } } } + + set do_sizes_d [expr {"d" in $sized_types}] + set do_sizes_f [expr {"f" in $sized_types}] + set do_sizes_l [expr {"l" in $sized_types}] + set do_times_d [expr {"d" in $timed_types}] + set do_times_f [expr {"f" in $timed_types}] + set do_times_l [expr {"l" in $timed_types}] + if {[llength $types_entry] && "d" ni $types_entry} { + set skip_dirs 1 + } else { + set skip_dirs 0 + } + if {[llength $types_entry] && "f" ni $types_entry} { + set skip_files 1 + } else { + set skip_files 0 + } + if {[llength $types_entry] && "l" ni $types_entry} { + set skip_links 1 + } else { + set skip_links 0 + } + set trequire_hidden [expr {"hidden" in $types_REQUIRED}] + set trequire_readonly [expr {"readonly" in $types_REQUIRED}] + set trequire_executable [expr {"x" in $types_REQUIRED}] + set trequire_readable [expr {"r" in $types_REQUIRED}] + set trequire_writable [expr {"w" in $types_REQUIRED}] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- # The repeated globs are a source of slowness for this function. @@ -1813,56 +1844,42 @@ namespace eval punk::du { if {$opt_glob eq "*"} { #Note - multiple glob operations with restrictions seem to be faster than looped tests like 'file isdirectory' & 'file readlink' #set parent [lindex $folders $folderidx] - if {![llength $types_entry] || "d" in $types_entry} { - #we need to check directories for hidden attribute - as on windows, not all dotfiles are hidden, and not all hidden files are dotfiles - set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} * .*] - set dirs [glob -nocomplain -dir $folderpath -types d * .*] - } - if {![llength $types_entry] || "l" in $types_entry} { - set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} * .*] - set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique - } - if {![llength $types_entry] || "f" in $types_entry} { - set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} * .*] - set files [glob -nocomplain -dir $folderpath -types f * .*] - } + set globs [list *] } else { - if {![llength $types_entry] || "d" in $types_entry} { - #we need to check directories for hidden attribute - as on windows, not all dotfiles are hidden, and not all hidden files are dotfiles - set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} $opt_glob] - set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] - } - if {![llength $types_entry] || "l" in $types_entry} { - set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} $opt_glob] - set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique - } - if {![llength $types_entry] || "f" in $types_entry} { - set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} $opt_glob] - set files [glob -nocomplain -dir $folderpath -types f $opt_glob] - } + set globs [list $opt_glob] + } + #on windows this is a lot of separate globs to perform. Using the du_dirlisting_twapi is preferred for performance on windows - but this is a fallback and for testing. + #if {![llength $types_entry] || "d" in $types_entry} {} + if {!$skip_dirs} { + #we need to check directories for hidden attribute - as on windows, not all dotfiles are hidden, and not all hidden files are dotfiles + set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} {*}$globs] + set dirs [glob -nocomplain -dir $folderpath -types d {*}$globs] + } + if {!$skip_links} { + set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} {*}$globs] + set links [glob -nocomplain -dir $folderpath -types l {*}$globs] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique + } + if {!$skip_files} { + set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} {*}$globs] + set files [glob -nocomplain -dir $folderpath -types f {*}$globs] } } else { if {$opt_glob eq "*"} { - #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink' - #set parent [lindex $folders $folderidx] - #set dirs [glob -nocomplain -dir $folderpath -types d * .*] - #set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique - #set files [glob -nocomplain -dir $folderpath -types f * .*] set globs [list * .*] } else { set globs [list $opt_glob] - #set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] - #set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique - #set files [glob -nocomplain -dir $folderpath -types f $opt_glob] } - - if {![llength $types_entry] || "d" in $types_entry} { + #we need to classify our results - unlike a standard glob * operation which returns all entries in one collection. + #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink' + #however - these are still significantly slower than a single glob with no restrictions - so we want to minimize the number of globs we do + #- but we also want to avoid doing extra work classifying entries that we will end up ignoring based on types/attributes/permissions filters. + if {!$skip_dirs} { set dirs [glob -nocomplain -dir $folderpath -types d {*}$globs] } - if {![llength $types_entry] || "l" in $types_entry} { + if {!$skip_links} { set links [glob -nocomplain -dir $folderpath -types l {*}$globs] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique } - if {![llength $types_entry] || "f" in $types_entry} { + if {!$skip_files} { set files [glob -nocomplain -dir $folderpath -types f {*}$globs] } @@ -1957,6 +1974,7 @@ namespace eval punk::du { set types_entry [list] set types_attribute [list] set types_permission [list] + set types_REQUIRED [list] foreach t $entry_and_attribute_types { switch -- $t { f - d - l - p - s - b - c { @@ -2155,7 +2173,7 @@ namespace eval punk::du { set errors [dict create] if {"windows" eq $::tcl_platform(platform)} { if {$opt_glob eq "*"} { - set globs [list * .*] + set globs [list *] } else { set globs [list $opt_glob] } @@ -2295,6 +2313,13 @@ namespace eval punk::du { #we don't classify anything as 'flaggedhidden' on unix. #it is a convention for dotfiles rather than a flag - and we'll leave the distinction for the display library + set dirs {} + set hdirs {} + set files {} + set hfiles {} + set links {} + set hlinks {} + if {$opt_glob eq "*"} { set globs [list * .*] } else { @@ -2341,6 +2366,7 @@ namespace eval punk::du { if {"$ft" in $meta_types} { foreach path [set $lvar] { if {$has_winpath && [punk::winpath::illegalname_test $path]} { + #review. we don't want to fix the path - we just want classify it as nonportable set testpath [punk::winpath::illegalname_fix $path] if {![catch {file stat $testpath arrstat} errM]} { dict set meta_dict $path [dict create shorttype $ft {*}[array get arrstat]] @@ -2350,7 +2376,7 @@ namespace eval punk::du { dict set meta_dict $path [dict create shorttype $ft {*}$empty_stat_dict] } } else { - #caller may have read perm on the containing folder - but not on child item - so file stat could raise an error + #caller may have permission to read on the containing folder - but not on child item - so file stat could raise an error if {![catch {file stat $path arrstat} errM]} { dict set meta_dict $path [dict create shorttype $ft {*}[array get arrstat]] } else { @@ -2463,28 +2489,38 @@ namespace eval punk::du { } proc du_dirlisting_undecided {folderpath args} { - if {"windows" eq $::tcl_platform(platform)} { - #jmn disable twapi - #tailcall du_dirlisting_generic $folderpath {*}$args - - package require zzzload - set loadstate [zzzload::pkg_require twapi] - if {$loadstate ni [list loading failed]} { - #either already loaded by zzload or ordinary package require - package require twapi ;#should be fast once twapi dll loaded in zzzload thread - set ::punk::du::has_twapi 1 - punk::du::active::set_active_function du_dirlisting du_dirlisting_twapi - tailcall du_dirlisting_twapi $folderpath {*}$args - } else { - if {$loadstate eq "failed"} { - puts stderr "punk::du defaulting to du_dirlisting_generic because twapi load failed" - punk::du::active::set_active_function du_dirlisting du_dirlisting_generic + switch -- $::tcl_platform(platform) { + windows { + #jmn disable twapi + #tailcall du_dirlisting_generic $folderpath {*}$args + + package require zzzload + set loadstate [zzzload::pkg_require twapi] + + if {$loadstate ni [list loading failed]} { + #either already loaded by zzload or ordinary package require + package require twapi ;#should be fast once twapi dll loaded in zzzload thread + set ::punk::du::has_twapi 1 + punk::du::active::set_active_function du_dirlisting du_dirlisting_twapi + tailcall du_dirlisting_twapi $folderpath {*}$args + } else { + if {$loadstate eq "failed"} { + puts stderr "punk::du defaulting to du_dirlisting_generic because twapi load failed" + punk::du::active::set_active_function du_dirlisting du_dirlisting_generic + } + tailcall du_dirlisting_generic $folderpath {*}$args } - tailcall du_dirlisting_generic $folderpath {*}$args } - } else { - punk::du::active::set_active_function du_dirlisting du_dirlisting_unix - tailcall du_dirlisting_unix $folderpath {*}$args + default { + #todo - macOS specific optimizations? e.g using macos metadata to determine hidden/readonly/system flags etc? + #macOS uses a case-insensitive filesystem by default like windows. + + #punk::du::active::set_active_function du_dirlisting du_dirlisting_unix + #tailcall du_dirlisting_unix $folderpath {*}$args + + punk::du::active::set_active_function du_dirlisting du_dirlisting_generic + tailcall du_dirlisting_generic $folderpath {*}$args + } } } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm index e816e1ef..9de4a33d 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm @@ -127,9 +127,14 @@ namespace eval punk::mix::util { foreach p $finalpaths { if {$has_winlnk && [file extension $p] eq ".lnk"} { set resolve_info [punk::winlnk::resolve $p] - set resolved [dict get $resolve_info link_target] + set resolved [dict get $resolve_info link_roottarget] if {$resolved ne ""} { - lappend resolved_finalpaths $resolved + if {[dict exists $resolve_info stringdata command_line_arguments]} { + puts stderr "link $p has arguments. Will cat the .lnk file itself rather than the root target." + lappend resolved_finalpaths $p + } else { + lappend resolved_finalpaths $resolved + } } else { lappend resolved_finalpaths $p } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm index 24dfad86..6d877c5f 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm @@ -157,6 +157,177 @@ tcl::namespace::eval punk::nav::fs { #[list_begin definitions] + #only lookup user_home once per interp or process + #It can be slightly expensive (for example involving network calls on windows domains) + variable user_home_cache + set user_home_cache "" + + #tilde + #These aliases work fine for interactive use - but the result is always a string internal-rep + #interp alias {} ~ {} file join $::env(HOME) ;#HOME must be capitalized to work cross platform (lowercase home works on windows - but probably not elsewhere) + #interp alias {} ~ {} apply {args {file join $::env(HOME) $args}} + namespace eval argdoc { + punk::args::define { + @id -id ::punk::nav::fs::~ + @cmd -name "punk::nav::fs::~"\ + -summary\ + "Return user's home directory as the process sees it"\ + -help\ + "Return the user's home directory path as the process sees it. + + (This is not always the same as ::env(HOME)) + + With additional arguments, return the path obtained by joining + the user's home directory with the supplied arguments. + + usage e.g + cd [~] + (change to user's home) + .// [~] .config + (change to .config directory within the user's home + and list contents.) + equivalently: + gohome .config + (gohome uses the output of ~ to determine the home directory) + + If the home directory cannot be determined due to the environment + in which the process is running, an error will be raised, as returning + an empty string is not a useful result and can cause issues if used as a path. + " + @opts + @values -min 0 -max -1 + arg -type any -optional 1 -multiple 1 + } + } + proc ~ {args} { + #review - HOME may be undefined or have been set to another value by other tools or the parent process. + #The process may even be running in a context where there is no home directory - e.g a container with no users, or a system service context. + #(we may be in a safe interp - which generally won't have env vars or filesystem access) + variable user_home_cache + if {$user_home_cache ne ""} { + set hdir $user_home_cache + #we still need to process args to join them to the home directory - but we can skip all the work of determining the home directory again. + } else { + set hdir "" + + if {[catch {auto_execok whoami} whoami_exe]} { + set whoami_exe "" + } + if {$whoami_exe eq ""} { + #try env USER or USERNAME - these are commonly set to the username on many platforms - but may not be set in all contexts. + if {[info exists ::env(USER)]} { + set user $::env(USER) + } elseif {[info exists ::env(USERNAME)]} { + set user $::env(USERNAME) + } else { + set user "" + } + } else { + #set user [exec {*}$whoami_exe] + if {[catch {exec {*}$whoami_exe} user]} { + set user "" + } + } + if {[string trim $user] ne ""} { + #normalize user for use with 'file tildeexpand ~' + #on windows, whoami may return DOMAIN\USER + #for tildeexpand to work, we need to convert this to USER@DOMAIN + if {"windows" eq $::tcl_platform(platform)} { + set parts [split $user "\\"] + #we expect only 1 or 2 parts + if {[llength $parts] == 2} { + lassign $parts domain username + + #if we use username@domain format - we get the domain controller's view of our home directory - which can be different from the local machine's view of our home directory. + #e.g file tildeexpand ~jnoble@corp can return a local non existant path like c:/users/jnoble + #but it may be c:/users/jnoble.corp - or c:/users/something_else_entirely depending on how the local machine is configured. + #It may be that the domain controller is correct if it returns a network path like \\server\users\jnoble ?? + #Network paths are not necessarily the preferred practive as of 2026 - but may still exist. + #Microsoft is encouraging the use of cloud systems - but it it unknown at this stage what sort of paths can be returned. + + #REVIEW + + set domainuser "$username@$domain" + #we can run file tildeexpand with username@domain and test if the path is writable + #this reduces the possibility that there happens to be a local user with the same name as the domain user - which would cause us to get the wrong home directory. + if {![catch {file tildeexpand ~$domainuser} path]} { + if {[file writable $path]} { + set user $domainuser + set hdir $path ;#set hdir so we don't re-lookup below. + } + } + if {$hdir eq ""} { + #for now we will use the unqualified username. + set user $username + } + + } elseif {[llength $parts] == 1} { + set user [lindex $parts 0] + } else { + #unexpected format - emit warning + puts stderr "Warning: Unexpected format of username '$user' returned by whoami. Expected format 'DOMAIN\\USER' or 'USER'. Unable to determine home directory for this user." + set user "" + } + } + + #only enter this branch if hdir wasn't resolved above for windows domain user. + if {$hdir eq "" && $user ne ""} { + #we use file tildeexpand ~user because the intention is stated in the tcl source as: + #* the intent is to retrieve (as on Unix) the system's view + #* of the home irrespective of environment settings of HOME + #* and USERPROFILE. + # - this aligns with our intention here. + if {![catch {file tildeexpand ~$user} path]} { + set hdir [punk::valcopy $path] + } else { + #tcl <= 8.6 may not have file tildeexpand. + #we now have no option but to rely on environment variables - which may not be set or may be set to an incorrect value + #as tcl <= 8.6 needs to be supported - but isn't the primary target we will allow this fallback - but raise a warning as this is not ideal. + puts stderr "punk::nav::fs::~ Warning: Unable to determine home directory for user '$user' using 'file tildeexpand ~$user'. Falling back to environment variables, which may not be set or may be incorrect. Consider upgrading to Tcl 9.0 or later for improved reliability." + if {"windows" eq $::tcl_platform(platform)} { + if {[info exists ::env(USERPROFILE)]} { + set hdir [punk::valcopy $::env(USERPROFILE)] + } else { + set hdir "" + } + } else { + if {[info exists ::env(HOME)]} { + set hdir [punk::valcopy $::env(HOME)] + } else { + set hdir "" + } + } + } + } + } + } + + if {$hdir eq ""} { + error "punk::nav::fs::~ Unable to determine home directory for user '$user'. Consider upgrading to Tcl 9.0 or later for improved reliability in home directory detection." + } + + file pathtype $hdir ;#flips internal-rep to path + if {![file isdirectory $hdir]} { + #file isdirectory should also return true if the path exists and is a symlink to a directory - but if it doesn't exist at all - or is a file - then we have a problem. + error "punk::nav::fs::~ Determined home directory path '$hdir' does not exist (or is not a directory)." + } else { + if {![file readable $hdir]} { + error "punk::nav::fs::~ Determined home directory path '$hdir' is not readable." + } + } + + set user_home_cache $hdir ;#cache only the home directory. + + set d $hdir + #use the file join 2-arg optimisation to avoid losing path-rep - probably doesn't give any advantage on all Tcl versions + #review - for what versions does/did the 2-arg version of file join not just return a string? + foreach a $args { + set d [file join $d $a] + } + file pathtype $d + return [punk::valcopy $d] + } + punk::args::define { @id -id ::punk::nav::fs::d/ @cmd -name punk::nav::fs::d/ -help\ @@ -624,9 +795,11 @@ tcl::namespace::eval punk::nav::fs { return $result } + + #---------------------------------------------------- punk::args::define { - @id -id ::punk::nav::fs::d/new - @cmd -name punk::nav::fs::d/new\ + @id -id ::punk::nav::fs::newdir + @cmd -name punk::nav::fs::newdir\ -summary\ "Create directory or directories at the specified path(s)."\ -help\ @@ -662,9 +835,9 @@ tcl::namespace::eval punk::nav::fs { created for some reason (e.g other filesystem error) then an error will be raised and processing of any remaining paths will be aborted." } - #todo - synchronize overall behaviour of d/new with that of n/new (for namespaces) - proc d/new {args} { - set argd [punk::args::parse $args withid ::punk::nav::fs::d/new] + #todo - synchronize overall behaviour of newdir with that of newns (for namespaces) + proc newdir {args} { + set argd [punk::args::parse $args withid ::punk::nav::fs::newdir] lassign [dict values $argd] leaders opts values received set paths [dict get $values path] set allow_nonportable [dict exists $received -nonportable] @@ -678,12 +851,12 @@ tcl::namespace::eval punk::nav::fs { set error_paths [list] foreach p $paths { if {!$allow_nonportable && [punk::winpath::illegalname_test $p]} { - #error "punk::nav::fs::d/new Path '$p' is not portable and may not be created without -nonportable option" + #error "punk::nav::fs::newdir Path '$p' is not portable and may not be created without -nonportable option" lappend error_paths [list $p "Path '$p' is not portable and may not be created without -nonportable option"] continue } if {[string first \0 $p] != -1} { - #error "punk::nav::fs::d/new Path '$p' contains null character which is not allowed" + #error "punk::nav::fs::newdir Path '$p' contains null character which is not allowed" lappend error_paths [list $p "Path '$p' contains null character which is not allowed"] continue } @@ -699,7 +872,7 @@ tcl::namespace::eval punk::nav::fs { set parent [file dirname $parent] } if {![file writable $parent]} { - #error "punk::nav::fs::d/new Cannot create directory '$fullpath' as parent '$parent' is not writable" + #error "punk::nav::fs::newdir Cannot create directory '$fullpath' as parent '$parent' is not writable" lappend error_paths [list $fullpath "Cannot create directory '$fullpath' as parent '$parent' is not writable"] continue } @@ -713,7 +886,7 @@ tcl::namespace::eval punk::nav::fs { set m [lindex $e 1] append path_error_display " Path: '$p' Error: $m\n" } - error "punk::nav::fs::d/new One or more supplied paths were invalid or not writable:\n$path_error_display" + error "punk::nav::fs::newdir One or more supplied paths were invalid or not writable:\n$path_error_display" } set num_created 0 @@ -730,17 +903,56 @@ tcl::namespace::eval punk::nav::fs { incr num_created } if {$error_string ne ""} { - error "punk::nav::fs::d/new $error_string\n$num_created directories out of [llength $fullpath_list] were created successfully before the error was encountered." + error "punk::nav::fs::newdir $error_string\n$num_created directories out of [llength $fullpath_list] were created successfully before the error was encountered." } #display summaries of created directories (which may have already existed) by reusing d/ to get info on them. set query_paths [lmap v $paths {string cat $v "/*"}] d/ / {*}$query_paths } + #---------------------------------------------------- + - #todo use unknown to allow d/~c:/etc ?? - proc d/~ {args} { - set home $::env(HOME) + punk::args::define { + @id -id ::punk::nav::fs::lib::gohome + @cmd -name punk::nav::fs::lib::gohome\ + -summary\ + "Navigate to a path relative to the current user's home directory."\ + -help\ + "Navigate to a path relative to the user's home directory. + + This may usually correspond to the HOME environment variable, but some + tools may have pointed HOME elsewhere, so the home directory is determined + based on the current user as determined using the whoami command, which is + almost universally available on platforms that Tcl runs on, and should be + unaffected by any changes to environment variables. + + This is a convenience function for quickly navigating to commonly used + locations within the home directory, without having to type out the full + path or use environment variables. + + Like the './' command, this navigates to the folder and then lists the sub-directories, + with a summary of the number of sub-directories and files, and total file size in bytes. + + " + @values -min 1 -max -1 + path -type string -optional 1 -multiple 1 -help\ + "Path relative to home directory to navigate to. + If the path does not exist, or is not a directory, then an error will be raised. + Examples: + gohome - will navigate to $HOME + (equivalent: gohome .) + gohome subdir1/subdir2 - will navigate to $HOME/subdir1/subdir2 + (equivalent: gohome subdir1 subdir2) + gohome subdir1 - will navigate to $HOME/subdir1 + + An absolute path is also accepted, but then the navigation is not relative to the home + directory and is effectively just a normal navigation to the specified path. + (equivalent to using ./ ) + " + } + proc gohome {args} { + set home [punk::nav::fs::~] set target [file join $home {*}$args] if {![file isdirectory $target]} { error "Folder $target not found" @@ -1731,10 +1943,11 @@ tcl::namespace::eval punk::nav::fs { if {![catch {package require punk::winlnk}]} { set target_type "file" ;#default/fallback - set shortcutinfo [punk::winlnk::resolve $fname] - if {[dict exists $shortcutinfo link_target]} { + set shortcutinfo [punk::winlnk::resolve $fname] ;#will always return a dict. Will only contain error key if there was an error. + + if {[dict exists $shortcutinfo link_roottarget]} { set is_valid_lnk 1 - set tgt [dict get $shortcutinfo link_target] + set root_tgt [dict get $shortcutinfo link_roottarget] set link_target_type [dict get $shortcutinfo target_type] switch -- $link_target_type { file { @@ -1744,12 +1957,12 @@ tcl::namespace::eval punk::nav::fs { set target_type "directory" } unknown { - #fall back to checking attributes and filesystem if we have a link_target but no target_type - if {[file exists $tgt]} { + #fall back to checking attributes and filesystem if we have a link_roottarget but no target_type + if {[file exists $root_tgt]} { #file type could return 'link' - we will use isfile/isdirectory - if {[file isfile $tgt]} { + if {[file isfile $root_tgt]} { set target_type file - } elseif {[file isdirectory $tgt]} { + } elseif {[file isdirectory $root_tgt]} { set target_type directory } else { set target_type file ;## ? @@ -1761,26 +1974,32 @@ tcl::namespace::eval punk::nav::fs { } } } else { - #no link_target - probably an ordinary file - but there could have been some other error in reading the binary windows lnk format. + #no link_roottarget - probably an ordinary file - but there could have been some other error in reading the binary windows lnk format. set is_valid_lnk 0 } if {$is_valid_lnk} { switch -- $target_type { file { set display [dict get $fdict display] - set display "$fshortcut_style$display (shortcut $tgt)" ;# + if {[dict exists $shortcutinfo stringdata command_line_arguments]} { + set display "$fshortcut_style$display (shortcut to $root_tgt [dict get $shortcutinfo stringdata command_line_arguments])" + } else { + set display "$fshortcut_style$display (shortcut $root_tgt)" ;# + } dict set fdict display $display lappend finfo_plus $fdict } directory { #target of link is a dir - for display/categorisation purposes we want to see it as a dir #will be styled later based on membership of dir_shortcuts + #review: we shouldn't see a link to a dir that also has command_line_arguments + #- but if we do, we will just ignore the command_line_arguments for now and treat as a directory shortcut. lappend dirs $fname lappend dir_shortcuts $fname } } } else { - #we were unable to get link_target - but we still need to check if it failed the header check (then assume not intended to be a windows shell lnk) or for some other reason. + #we were unable to get link_roottarget - but we still need to check if it failed the header check (then assume not intended to be a windows shell lnk) or for some other reason. if {[dict exists $shortcutinfo error]} { if {[dict get $shortcutinfo error] ne "lnk_header_check_failed"} { #Presumably there is a valid lnk header, but some unexpected error occurred - show it in the display for the file @@ -1794,9 +2013,10 @@ tcl::namespace::eval punk::nav::fs { lappend finfo_plus $fdict } } else { - #shouldn't ever happen. If no error, then there should have been a link_target + #shouldn't ever happen. If no error, then there should have been a link_roottarget #report and move on - puts stderr "Unexpected error in result of parsing binary format for $fname" + puts stderr "Unexpected error in result of parsing binary format for $fname." + puts stderr "Result was [showdict $shortcutinfo]" lappend finfo_plus $fdict } } @@ -2079,6 +2299,7 @@ tcl::namespace::eval punk::nav::fs::system { } +interp alias {} ~ {} punk::nav::fs::~ interp alias {} ./ {} punk::nav::fs::d/ / interp alias {} d/ {} punk::nav::fs::d/ / interp alias {} .// {} punk::nav::fs::d/ // @@ -2093,10 +2314,12 @@ interp alias {} dirfiles {} punk::nav::fs::dirfiles interp alias {} dirfiles_dict {} punk::nav::fs::dirfiles_dict interp alias {} fglob {} punk::nav::fs::fglob -interp alias {} ./new {} punk::nav::fs::d/new -interp alias {} d/new {} punk::nav::fs::d/new -interp alias {} ./~ {} punk::nav::fs::d/~ -interp alias {} d/~ {} punk::nav::fs::d/~ +interp alias {} newdir {} punk::nav::fs::newdir + +#this also conflicts with auto_cd as there could be a local folder (or file) called ~. +interp alias {} gohome {} punk::nav::fs::gohome + +#review interp alias {} x/ {} punk::nav::fs::x/ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/ns-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/ns-0.1.0.tm index 16cb13a1..6a336808 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/ns-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/ns-0.1.0.tm @@ -94,7 +94,8 @@ tcl::namespace::eval punk::nav::ns { if {[llength $ensemble_info] > 0} { #this namespace happens to match ensemble command. #todo - keep cache of encountered ensembles from commands.. and examine namespace in the configure info. - set ns_display "\n[a+ yellow bold]$ns_current (ensemble)[a+]" + #don't rely on a+ alias here. + set ns_display "\n[punk::ansi::a+ yellow bold]$ns_current (ensemble)[punk::ansi::a+]" } } } @@ -103,11 +104,86 @@ tcl::namespace::eval punk::nav::ns { return $out } - #create possibly nested namespace structure - but only if not already existant - proc n/new {args} { + #create possibly nested namespace structure(s) - todo: allow specifying namespaces or which already or partially already exist. + #todo - sync with newdir behaviour. + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::punk::nav::ns::newns + @cmd -name punk::nav::ns::newns\ + -summary\ + "Create namespace or namespaces at the specified path(s)."\ + -help\ + "This command creates namespaces at the specified path(s). + If any part of the specified path does not exist, then it will be created as well. + If a specified path already exists, then it will be left as-is and no error will be raised. + + A summary line is returned for each created namespace, with the full path of the created + namespace and a status line indicating the number of child namespaces, commands and vars in + the namespace if it already existed (or showing 0 for all if it was just created). + (summary incomplete - todo)" + -force -type none\ + -help\ + "Allows creation of namespaces which may be unwise/problematic, such as empty string + or namespaces with leading colons. + Use with caution and only when you know what you are doing. + If -force is not supplied, then an error will be raised if any supplied + path is problematic and no namespaces will be created." + @values -min 1 -max -1 -type string + path -type string -multiple 1 -optional 0 -help\ + "Path(s) (possibly with namespace separator ::) to create. + Can be absolute or relative to current namespace. + If any path is rejected, then no namespaces will be created. + + If a namespace or part of a namespace already exists, then it will be left as-is and no + error will be raised. + + If despite passing the name tests, a namespace cannot be created for some reason then an + error will be raised and processing of any remaining paths will be aborted." + }] + } + proc newns {args} { + set argd [punk::args::parse $args withid ::punk::nav::ns::newns] + lassign [dict values $argd] _leaders opts values _received + if {[dict exists $opts -force]} { + set opt_force [dict get $opts -force] + } else { + set opt_force 0 + } + set paths [dict get $values path] + + variable ns_current + + #todo: like newdir we want to try to perform an all-or-nothing operation - so first validate all namespaces to be created before creating any of them. + + set ns [lindex $paths 0] ;#temporary - full implementation will loop through $paths. + set is_absolute [string match ::* $ns] + if {$is_absolute} { + set nspath $ns + } else { + if {[string match :* $ns]} { + #todo - disallow by default and require flag to force. + #we also should disallow by default ::: (or any odd multiple? perhaps even :::: for empty ns should require -force) in between segments. + puts stderr "newns WARNING namespace with leading colon '$ns' is likely to have unexpected results" + } + set nspath [nsjoin $ns_current $ns] + } + + set ns_exists [nseval [nsprefix $nspath] [list ::tcl::namespace::exists [nstail $nspath] ]] + + if {$ns_exists} { + error "Namespace $nspath already exists" + } + #tcl::namespace::eval [nsprefix $nspath] [list tcl::namespace::eval [nstail $nspath] {}] + nseval [nsprefix $nspath] [list ::tcl::namespace::eval [nstail $nspath] {}] + + #display summaries of created directories (which may have already existed) by reusing d/ to get info on them. + set query_paths [lmap v $paths {string cat $v "::*"}] + ns/ / {*}$query_paths + } + proc newns_old {args} { variable ns_current if {![llength $args]} { - error "usage: :/new \[ ...\]" + error "usage: newns \[ ...\]" } set a1 [lindex $args 0] set is_absolute [string match ::* $a1] @@ -115,7 +191,7 @@ tcl::namespace::eval punk::nav::ns { set nspath [nsjoinall {*}$args] } else { if {[string match :* $a1]} { - puts stderr "n/new WARNING namespace with leading colon '$a1' is likely to have unexpected results" + puts stderr "newns WARNING namespace with leading colon '$a1' is likely to have unexpected results" } set nspath [nsjoinall $ns_current {*}$args] } @@ -130,6 +206,7 @@ tcl::namespace::eval punk::nav::ns { n/ $nspath } + #nn/ ::/ nsup/ - back up one namespace level proc nsup/ {v args} { variable ns_current @@ -160,14 +237,13 @@ tcl::namespace::eval punk::nav::ns { interp alias {} n/ {} punk::nav::ns::ns/ / interp alias {} n// {} punk::nav::ns::ns/ // interp alias {} n/// {} punk::nav::ns::ns/ /// -interp alias {} n/new {} punk::nav::ns::n/new +interp alias {} newns {} punk::nav::ns::newns interp alias {} nn/ {} punk::nav::ns::nsup/ / interp alias {} nn// {} punk::nav::ns::nsup/ // if 0 { -#we can't have ::/ without just plain / which is confusing. interp alias {} :/ {} punk::nav::ns::ns/ / interp alias {} :// {} punk::nav::ns::ns/ // -interp alias {} :/new {} punk::nav::ns::n/new +#we can't have ::/ without just plain / which is confusing. interp alias {} ::/ {} punk::nav::ns::nsup/ / interp alias {} ::// {} punk::nav::ns::nsup/ // } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm index 883f82de..b90c3b3b 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm @@ -3416,8 +3416,8 @@ y" {return quirkykeyscript} lappend usageinfo $c set found_documentation 1 } - #todo - alias to an alias - #e.g n/new jjj + #todo? - alias to an alias + #e.g newns jjj # interp alias "" ::jjj::corp2 "" ::corp #todo -pseudocode #cmdwhich id diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/winlnk-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/winlnk-0.1.1.tm index 7ad2ba89..6c31f56a 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/winlnk-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/winlnk-0.1.1.tm @@ -75,6 +75,10 @@ tcl::namespace::eval punk::winlnk { #[para] Core API functions for punk::winlnk #[list_begin definitions] + #todo - review internal API. + #A lot of these functions accept the raw contents of a .lnk file. + #It may make sense to use an OO approach to avoid reparsing of contents when calling multiple functions on the same .lnk file. + variable magic_HeaderSize "0000004C" ;#HeaderSize MUST equal this variable magic_LinkCLSID "00021401-0000-0000-C000-000000000046" ;#LinkCLSID MUST equal this @@ -853,14 +857,14 @@ tcl::namespace::eval punk::winlnk { set suffix_path "" set linkinfocontent [dict get $linkinfo_content_dict content] set next_start [dict get $linkinfo_content_dict next_start] ;#location of section following LinkInfo (Location information) - this will be the Data Strings. - set link_target "" + set link_roottarget "" set linkfields [dict create] if {$linkinfocontent ne ""} { set linkfields [LinkInfo_get_fields $linkinfocontent] set localbase_path [dict get $linkfields localbasepath] set suffix_path [dict get $linkfields commonpathsuffix] if {"windows" eq $::tcl_platform(platform)} { - set link_target [file join $localbase_path $suffix_path] + set link_roottarget [file join $localbase_path $suffix_path] } else { #review - calling mount and parsing its output every time we parse a .lnk file makes this slow on large folders with .lnk files # - we may want to cache the results of mount for some period of time or until we detect a change in the system's mounts (e.g. by monitoring /proc/mounts for changes or using a filesystem watcher on /mnt) @@ -868,24 +872,24 @@ tcl::namespace::eval punk::winlnk { if {[regexp {([a-zA-Z]):\\(.*)} $localbase_path _match drive_letter tail]} { set localbase_path [string map {\\ /} $localbase_path] set tail [string trimleft [string map {\\ /} $tail] /] - set link_target "" + set link_roottarget "" #shortcut basepath is a windows path with drive letter - try to resolve it on unix by looking for a corresponding mount from fstab or a point under /mnt set mountinfo [exec mount] foreach line [split $mountinfo "\n"] { #review - a more specific mount target might exist that includes the drive letter as part of the mount point name and is a longer prefix of the localbase_path #- we should probably look for the longest prefix match rather than just the drive letter if {[regexp -nocase -- [string cat ^$drive_letter {:\\\s+on\s+(\S+)}] $line _match mount_point]} { - set link_target [file join $mount_point $tail $suffix_path] + set link_roottarget [file join $mount_point $tail $suffix_path] break } } - if {$link_target eq ""} { + if {$link_roottarget eq ""} { #review - under what circumstances could this happen? If the drive letter doesn't match any mount points, then /mnt/drive_letter should generally already have been found above above # - However, it may be possible for /mnt/drive_Letter to still exist even if it's not reflected in the output of mount or the output of mount is in an unexpected format. #nothing in mount result matches the drive letter - try looking for a mount point under /mnt with the drive letter as the name if {[file exists /mnt/$drive_letter]} { - set link_target [file join /mnt/$drive_letter $tail $suffix_path] + set link_roottarget [file join /mnt/$drive_letter $tail $suffix_path] } else { if {$drive_letter eq [string tolower $drive_letter]} { set op_drive_letter [string toupper $drive_letter] @@ -893,20 +897,20 @@ tcl::namespace::eval punk::winlnk { set op_drive_letter [string tolower $drive_letter] } if {[file exists /mnt/$op_drive_letter]} { - set link_target [file join /mnt/$op_drive_letter $tail $suffix_path] + set link_roottarget [file join /mnt/$op_drive_letter $tail $suffix_path] } else { #leave as is except for backslashes converted to forward #- probably won't resolve correctly unless the unix system has a folder named drive_letter: in the current folder with a copy of the original filestructure. - set link_target [file join $localbase_path $suffix_path] + set link_roottarget [file join $localbase_path $suffix_path] } } } else { - #shortcut basepath is a windows path with drive letter and we found a matching mount point - link_target is set to the resolved path + #shortcut basepath is a windows path with drive letter and we found a matching mount point - link_roottarget is set to the resolved path } } else { #shortcut basepath doesn't match expected windows path format - just join it with the suffix and hope for the best #could be something like a network path or it could be something else entirely - set link_target [file join $localbase_path $suffix_path] + set link_roottarget [file join $localbase_path $suffix_path] } } } @@ -929,14 +933,14 @@ tcl::namespace::eval punk::winlnk { set target_type [dict get $target_type_info type] set target_type_mech [dict get $target_type_info mechanism] if {$target_type eq "unknown"} { - if {[file exists $link_target]} { - set target_type [file type $link_target] + if {[file exists $link_roottarget]} { + set target_type [file type $link_roottarget] set target_type_mech "filesystem" } } set result [dict create\ - link_target $link_target\ + link_roottarget $link_roottarget\ link_flags $flags_enabled\ file_attributes $file_attributes\ creation_time [Header_Get_CreationTime $contents]\ @@ -1017,7 +1021,7 @@ tcl::namespace::eval punk::winlnk { package require punk::lib #punk::lib::showdict [resolve $path] */@* set field_queries [dict create\ - link_target link_target\ + link_roottarget link_roottarget\ link_flags link_flags/@*\ file_attributes file_attributes\ creation_time creation_time\ @@ -1055,32 +1059,33 @@ tcl::namespace::eval punk::winlnk { @id -id ::punk::winlnk::target @cmd -name punk::winlnk::target\ -summary\ - "Return the target path of a .lnk file (windows shortcut)"\ + "Return the target path/commandline of a .lnk file (windows shortcut)"\ -help\ - "Return the target path of the .lnk file specified in path. + "Return the target path/commandline of the .lnk file specified in path. This is a convenience function that extracts the target path from the .lnk file and returns it directly, without all the additional information that resolve provides. If the .lnk header check fails, then - the .lnk file probably isn't really a shortcut file and an error message will be returned. - - Incomplete! - needs to process arguments when HasArguments link flag is set and append the arguments to the target path. - - e.g for a shortcut to 'START /D ...' the target will currently just return a path to cmd.exe - which is insufficient." + the .lnk file probably isn't really a shortcut file and an error message will be returned." @values -min 1 -max 1 path -type string -help "Path to the .lnk file to resolve" }] } + #consider a shortcut to the following: # START /D ^"C:\tcl\bin^" wish.exe c:\cmdfiles\ftp.tcl" - # the target currently only returns c:/Windows/System32/cmd.exe. + # the link_roottarget is c:/Windows/System32/cmd.exe. + proc target {path} { - #*** !doctools - #[call [fun target] [arg path] ] - #[para]Return the target path of the .lnk file specified in path set info [resolve $path] if {[dict exists $info error]} { error [dict get $info error] } else { - return [dict get $info link_target] + set roottarget [dict get $info link_roottarget] + if {[dict exists $info stringdata command_line_arguments]} { + set arguments [dict get $info stringdata command_line_arguments] + return "$roottarget $arguments" + } else { + return $roottarget + } } } @@ -1094,7 +1099,9 @@ tcl::namespace::eval punk::winlnk { } proc Get_target_type {content file_attributes} { - #determine type based on info in the .lnk file, such as file attributes and link flags + #determine target file/directory/link type based on info in the .lnk file, such as file attributes and link flags + #review - a .lnk may target an executable with arguments. + #In this case, the target type may be considered a file (the executable) but it may also be useful to indicate that it's a link to an executable with arguments(?). if {"DIRECTORY" in $file_attributes} { return [dict create type directory mechanism file_attributes]" @@ -1104,31 +1111,31 @@ tcl::namespace::eval punk::winlnk { set iteminfo [Get_LinkTargetIDList_iteminfo $content] if {[llength $iteminfo] > 0} { set first_item [lindex $iteminfo 0] - set first_item_type [dict get $first_item type] + set first_item_type [dict get $first_item typehex] set saw_2f 0 switch -- $first_item_type { "1F" { #plain files and folders always seem to have a first item type of 1F #so does "local disk" - set type_so_far "unknown" - #For a file, we may first see multiple items of type 32 (directory) as we go through the folder structure, - #and then finally an item of type 31 (file) at the end. + set target_type_so_far "unknown" + #For a file, we may first see multiple items of typehex 32 (directory) as we go through the folder structure, + #and then finally an item of typehex 31 (file) at the end. #For a network location, we may see an item of type 2F. #So we need to loop through all the items and keep track of what we've seen so far. foreach item $iteminfo { - set item_type [dict get $item type] - if {$item_type eq "31"} { - set type_so_far "directory" - } elseif {$item_type eq "32"} { + set item_type_hex [dict get $item typehex] + if {$item_type_hex eq "31"} { + set target_type_so_far "directory" + } elseif {$item_type_hex eq "32"} { return [dict create type file mechanism idlist] - } elseif {$item_type eq "2F"} { + } elseif {$item_type_hex eq "2F"} { set saw_2f 1 } } - if {$type_so_far eq "unknown" && $saw_2f} { + if {$target_type_so_far eq "unknown" && $saw_2f} { return [dict create type "local disk" mechanism idlist] } - return [dict create type $type_so_far mechanism idlist] + return [dict create type $target_type_so_far mechanism idlist] } } return [dict create type "unknown" mechanism idlist] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/commandstack-0.4.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/commandstack-0.4.tm index 19c21289..165bd16a 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/commandstack-0.4.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/commandstack-0.4.tm @@ -167,6 +167,12 @@ namespace eval commandstack { lassign $arglist command procargs procbody set command [uplevel 1 [list namespace which $command]] + if {$command eq ""} { + #review + puts stderr "commandstack::rename_command no rename performed for command '$command' by '$renamer'. command '$command' not found in calling context. Ensure command name is fully qualified or that command exists." + #add something to stack? + return [dict create implementation ""] + } set mungedcommand [string map {:: _ns_} $command] set mungedrenamer [string map {:: _ns_} $renamer] variable all_stacks @@ -284,7 +290,8 @@ namespace eval commandstack { ] if {![dict get $nextinfo do_rename]} { #review - puts stderr "no rename performed" + puts stderr "commandstack::rename_command no rename performed for command '$command' by '$renamer'" + #add something to stack? return [dict create implementation ""] } catch {rename ::commandstack::temp::testproc ""} diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm index 5a7824f0..ebfb673f 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm @@ -35,29 +35,13 @@ namespace eval punk { " } - proc rehash {{refresh 0}} { - global auto_execs - if {!$refresh} { - unset -nocomplain auto_execs - } else { - set names [array names auto_execs] - unset -nocomplain auto_execs - foreach nm $names { - auto_execok_windows $nm - } - } - return - } proc ::punk::auto_execok_original name [info body ::auto_execok] variable better_autoexec - #set better_autoexec 0 ;#use this var via better_autoexec only - #proc ::punk::auto_execok_windows name { - # ::punk::auto_execok_original $name - #} + #use this var via better_autoexec only set better_autoexec 1 proc ::punk::auto_execok_windows name { ::punk::auto_execok_better $name @@ -166,14 +150,14 @@ namespace eval punk { proc ::punk::auto_execok_windows name { ::punk::auto_execok_better $name } - punk::rehash + punk::auto_exec::rehash } elseif {!$onoff && ($onoff != $better_autoexec)} { puts "Turning off better_autoexec - search extension then PATH" set better_autoexec 0 proc ::punk::auto_execok_windows name { ::punk::auto_execok_original $name } - punk::rehash + punk::auto_exec::rehash } else { puts "no change" } @@ -182,6 +166,16 @@ namespace eval punk { proc auto_execok_better name { + #review - we have a gneral problem of auto_exec caching negative results for relative paths. + #A failed resolution of a relative path should not generate an entry in ::auto_execs. + #This happens in plain tclsh - so we need to determine where in Tcl this happens and fix it there. + #Simply returning an empty string here will still result in a negative cache entry. + #we want to cache negative results for absolute paths or plain filenames with no file-separator. + #e.g ./doesntexist.exe should not be cached as not found, but should be re-resolved every time. (cwd dependent) + #e.g doesntexist.exe should be cached as not found, because it will always be not found until it appears in the PATH. + #i.e it is required to prefix with ./ to exec a file in the current directory. (similar to unix shells) + + global auto_execs env tcl_platform #for now at least, auto_execok_better is windows-specific. package require punk::auto_exec @@ -213,7 +207,16 @@ namespace eval punk { } if {[llength [file split $name]] != 1} { + #----------------------------------------------------- #has a path component - could be relative or absolute. + #----------------------------------------------------- + if {[file pathtype $name] eq "relative"} { + #don't cache negative result for any relative paths - as they may become valid if the file appears in the relative location, or if the user changes directory and the same relative path points to a different file. + #our only way to do this is by cooperating with the unknown handler. + set auto_execs($name) "for_unknown_handler by punk::auto_exec relative_path - file existence should be re-checked at call time" + return $auto_execs($name) + } + if {[string tolower [file extension $name]] eq ".lnk"} { #special case .lnk #todo - consider working directory or other properties of link before launching? @@ -246,11 +249,11 @@ namespace eval punk { set associnfo [punk::auto_exec::shell_open_command $test_ext] set valuetype [dict get $associnfo type] set assoc [dict get $associnfo value] - set ftype [dict get $associnfo filetype] + set windows_file_type [dict get $associnfo filetype] if {$assoc eq ""} { return [set auto_execs($name) [list $file]] } else { - if {[file pathtype $target] eq "relative" && $ftype eq "InternetShortcut"} { + if {[file pathtype $target] eq "relative" && $windows_file_type eq "InternetShortcut"} { #special case InternetShortcut - cannot accept relative path - so we can't cache it in auto_execs if we used a relative path to launch #if we return an empty string - the auto_exec will fail to launch this every time. #The best we can do is return a token for the 'unknown' process to detect and re-resolve the path every time. @@ -260,7 +263,7 @@ namespace eval punk { #e.g ::auto_execs(./link.url) = some.exe c:/desktop/link.url #this would be wrong if the user changed directory and tried to run ./link.url again on a different file with the same name # - as the cached path would no longer be correct. - return [set auto_execs($name) "(resolve_in_unknown_handler) punk::auto_exec absolute_path required"] + return [set auto_execs($name) "for_unknown_handler by punk::auto_exec absolute_path required"] } puts stderr "auto_execok_better: (review required) assoc $assoc for file $file ext $test_ext" set run [punk::auto_exec::shell_command_as_tcl_list -type $valuetype $assoc $file] ;# -workingdir [pwd] vs path of script? @@ -269,6 +272,8 @@ namespace eval punk { } } } + #cache negative result for absolute paths - as they will always point to the same location, so if they don't exist now, they won't exist later. + set auto_execs($name) "" return "" } @@ -559,7 +564,7 @@ if {![llength [info commands ::ansistring]]} { package require punk::repl::codethread package require punk::config #package require textblock -package require punk::console ;#requires Thread +catch {package require punk::console} ;#requires Thread - will not work in safe interps. package require punk::ns package require punk::winpath ;# for windows paths - but has functions that can be called on unix systems package require punk::repo @@ -5396,27 +5401,54 @@ namespace eval punk { } else { set repl_runid [punk::get_repl_runid] #set ::punk::last_run_display [list] - if {$new eq "(resolve_in_unknown_handler) punk::auto_exec absolute_path required"} { - #re-resolve. - puts "(unknown-handler): auto_execok for $name requires absolute path. Re-resolving $name with absolute path." + set resolved $new + if {[string match "for_unknown_handler *" $new]} { set ext [file extension $name] - set associnfo [punk::auto_exec::shell_open_command $ext] - set valuetype [dict get $associnfo type] - set assoc [dict get $associnfo value] - set ftype [dict get $associnfo filetype] - set fullpath [file normalize $name] - #at least for .url files - long paths (paths with multiple spaces?) can fail to run. Using the short path seems to fix this. - #This seems hacky but anyway.. - set attributes [file attributes $fullpath] - if {[dict exists $attributes -shortname]} { - set fullpath [dict get $attributes -shortname] + if {[string tolower $ext] eq ".lnk"} { + #for .lnk files we can often resolve the target path without needing to execute the shell open command + #- which is desirable because it allows us to avoid the absolute path requirement for unknown-handler auto_execok commands, + #which is desirable because it allows us to support relative paths and paths with environment variables in them + #(e.g for .lnk files that point to executables with environment variables in the path) + set targetinfo [punk::winlnk::resolve $name] + if {[dict exists $targetinfo link_roottarget]} { + set resolved [dict get $targetinfo link_roottarget] + #arguments? + } else { + puts "(unknown-handler): failed to resolve .lnk target for $name. Falling back to shell open command resolution, which may fail if absolute path is required." + } + } else { + #re-resolve. + set associnfo [punk::auto_exec::shell_open_command $ext] + set registry_valuetype [dict get $associnfo type] ;#sz vs expand_sz + set command_spec [dict get $associnfo value] + set windows_file_type [dict get $associnfo filetype] + if {[string match "*absolute_path required" $new]} { + puts "(unknown-handler): auto_execok for $name requires absolute path. Re-resolving $name with absolute path." + set fullpath [file normalize $name] + #at least for .url files - long paths (paths with multiple spaces?) can fail to run. Using the short path seems to fix this. + #This seems hacky but anyway.. + set attributes [file attributes $fullpath] + if {[dict exists $attributes -shortname]} { + set fullpath [dict get $attributes -shortname] + } + set resolved [punk::auto_exec::shell_command_as_tcl_list -type $registry_valuetype $command_spec $fullpath] + } else { + #todo + set newnorm [file normalize $name] + puts stderr "(unknown-handler): re-resolving $name with auto_execok $newnorm" + set resolved [auto_execok $newnorm] + } } - set new [punk::auto_exec::shell_command_as_tcl_list -type $valuetype $assoc $fullpath] } - + if {$resolved eq ""} { + #resolved may be emptyif auto_execok returns an empty string. + dict set ::tcl::UnknownOptions -code error + set ::tcl::UnknownResult "unresolved path '$name'" + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } set redir ">&@stdout <@stdin" - uplevel 1 [list ::catch [concat exec $redir $new [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions] + uplevel 1 [list ::catch [concat exec $redir $resolved [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions] #we can't detect stdout/stderr output from the exec #for now emit an extra \n on stderr #todo - there is probably no way around this but to somehow exec in the context of a completely separate console @@ -5502,8 +5534,7 @@ namespace eval punk { set default_cmd_search 0 if {$default_cmd_search} { if {[llength $cmds] == 1} { - uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] \ - ::tcl::UnknownResult ::tcl::UnknownOptions] + uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] ::tcl::UnknownResult ::tcl::UnknownOptions] dict incr ::tcl::UnknownOptions -level return -options $::tcl::UnknownOptions $::tcl::UnknownResult } @@ -6779,46 +6810,6 @@ namespace eval punk { - #tilde - #These aliases work fine for interactive use - but the result is always a string int-rep - #interp alias {} ~ {} file join $::env(HOME) ;#HOME must be capitalized to work cross platform (lowercase home works on windows - but probably not elsewhere) - #interp alias {} ~ {} apply {args {file join $::env(HOME) $args}} - namespace eval argdoc { - punk::args::define { - @id -id ::punk::~ - @cmd -name "punk::~"\ - -summary\ - "Return home directory"\ - -help\ - "Return the home directory path. With additional arguments, - return the path obtained by joining the home directory with - the supplied arguments. - - usage e.g - cd [~] - (change to home directory) - .// [~] .config - (change to .config directory within home directory - and list contents.) - " - @opts - @values -min 0 -max -1 - arg -type any -optional 1 -multiple 1 - } - } - proc ~ {args} { - set hdir [punk::valcopy $::env(HOME)] - file pathtype $hdir - set d $hdir - #use the file join 2-arg optimisation to avoid losing path-rep - probably doesn't give any advantage on all Tcl versions - #review - for what versions does/did the 2-arg version of file join not just return a string? - foreach a $args { - set d [file join $d $a] - } - file pathtype $d - return [punk::valcopy $d] - } - interp alias {} ~ {} punk::~ #maint - punk::args has similar @@ -7735,12 +7726,20 @@ namespace eval punk { -limit -type int -default 20 -help\ "When multiple values are passed to inspect - limit the number of elements displayed in -channel output. + When truncation has occured an elipsis indication (...) will be appended. e.g - .= lseq 20 to 50 by 3 |> .=>* inspect -limit 4 -- |> .=>* tcl::mathop::+ - (11) 20 23 26 29... + ${[punk::args::helpers::example { - - 385 + .= lseq 20 to 50 by 3 |> .=>* inspect -limit 4 -- |> .=>* tcl::mathop::+ + (11) 20 23 26 29... + + - 385 + + }]} + + If the current pipeline data is not a list, the limit is applied to the + number of lines in the pipeline value. For no limit - use -limit -1 " @@ -7881,11 +7880,11 @@ namespace eval punk { } if {$showcount} { set displaycount "[a purple bold]($count)[a] " - if {$showcount} { - set countspace [expr {[string length $count] + 3}] ;#lhs margin size of count number plus brackets and one space - set margin [string repeat " " $countspace] - set displayval [string map [list \r "" \n "\n$margin"] $displayval] - } + #if {$showcount} { + # set countspace [expr {[string length $count] + 3}] ;#lhs margin size of count number plus brackets and one space + # set margin [string repeat " " $countspace] + # set displayval [string map [list \r "" \n "\n$margin"] $displayval] + #} } else { set displaycount "" } @@ -7934,10 +7933,13 @@ namespace eval punk { } if {![string length $more]} { - puts $channel "$displaycount$label$displayval[a]" + #puts $channel "$displaycount$label$displayval[a]" + set chunk [textblock::join -- $displaycount$label " " $displayval[a]] } else { - puts $channel "$displaycount$label$displayval[a yellow bold]$more[a]" + #puts $channel "$displaycount$label$displayval[a yellow bold]$more[a]" + set chunk [textblock::join -- $displaycount$label " " "$displayval[a yellow bold]$more[a]"] } + puts $channel $chunk return $val } @@ -8024,7 +8026,7 @@ namespace eval punk { lappend cmdinfo [list ./ "?${I}glob${NI}?" "view/change dir, list dirs."] lappend cmdinfo [list ../ "?${I}path${NI}" "go up one dir, then to path if given"] lappend cmdinfo [list .// "?${I}glob${NI}?" "view/change dir, list dirs and files"] - lappend cmdinfo [list ./new "${I}subdir${NI}..." "make new dir or dirs and show status"] + lappend cmdinfo [list newdir "${I}subdir${NI}..." "make new dir or dirs and show status"] lappend cmdinfo [list fcat "${I}file ?file?...${NI}" "cat file(s)"] set t [textblock::class::table new -minwidth 80 -show_seps 0] foreach row $cmdinfo { @@ -8046,9 +8048,9 @@ namespace eval punk { set title "[a+ brightgreen] Namespace navigation: " set cmdinfo [list] lappend cmdinfo [list n/ "?${I}ns${NI}|${I}glob${NI}?" "view/change namespace\n (accepts ns path globs e.g **::*get* to match\n commands at any level )"] - lappend cmdinfo [list n// "?${I}ns${NI}|${I}glob${NI}?" "view/change namespace (with command listing)"] - lappend cmdinfo [list "nn/" "" "go up one namespace"] - lappend cmdinfo [list "n/new" "${I}ns${NI}" "make child namespace and switch to it"] + lappend cmdinfo [list n// "?${I}ns${NI}|${I}glob${NI}?" "view/change namespace (with command listing)"] + lappend cmdinfo [list "nn/" "" "go up one namespace"] + lappend cmdinfo [list "newns" "${I}ns${NI}" "make child namespace and switch to it"] set t [textblock::class::table new -minwidth 80 -show_seps 0] foreach row $cmdinfo { $t add_row $row @@ -8236,104 +8238,110 @@ namespace eval punk { lappend chunks [list stdout $text] } console - term - terminal { - set indent [string repeat " " [string length "WARNING: "]] - lappend cstring_tests [dict create\ - type "PM "\ - msg "UN"\ - f7 punk::ansi::controlstring_PM\ - f7prefix "7bit ESC ^ secret "\ - f7suffix "safe"\ - f8 punk::ansi::controlstring_PM8\ - f8prefix "8bit \\x9e secret "\ - f8suffix "safe"\ - ] - lappend cstring_tests [dict create\ - type SOS\ - msg "NOT"\ - f7 punk::ansi::controlstring_SOS\ - f7prefix "7bit ESC X string "\ - f7suffix " hidden"\ - f8 punk::ansi::controlstring_SOS8\ - f8prefix "8bit \\x98 string "\ - f8suffix " hidden"\ - ] - lappend cstring_tests [dict create\ - type APC\ - msg "NOT"\ - f7 punk::ansi::controlstring_APC\ - f7prefix "7bit ESC _ APPLICATION PROGRAM COMMAND "\ - f7suffix " hidden"\ - f8 punk::ansi::controlstring_APC8\ - f8prefix "8bit \\x9f APPLICATION PROGRAM COMMAND "\ - f8suffix " hidden"\ - ] + if {[catch {package require punk::console} result]} { + set text "Unable to load punk::console package - cannot test\n$result" + lappend chunks [list stdout $text] + } else { - foreach test $cstring_tests { - set m [[dict get $test f7] [dict get $test msg]] - set hidden_width_m [punk::console::test_char_width $m] - set m8 [[dict get $test f8] [dict get $test msg]] - set hidden_width_m8 [punk::console::test_char_width $m8] - if {$hidden_width_m != 0 || $hidden_width_m8 != 0} { - if {$hidden_width_m == 0} { - set d "[a+ green bold][dict get $test f7prefix][a red]${m}[a][a+ green bold][dict get $test f7suffix][a]" - } else { - set d "[a+ yellow bold][dict get $test f7prefix][a red]$m[a][a+ yellow bold][dict get $test f7suffix][a]" - } - if {$hidden_width_m8 == 0} { - set d8 "[a+ green ][dict get $test f8prefix][a red]$m8[a][a+ green][dict get $test f8suffix][a]" - } else { - set d8 "[a+ yellow bold][dict get $test f8prefix][a red]$m8[a][a+ yellow bold][dict get $test f8suffix][a]" + set indent [string repeat " " [string length "WARNING: "]] + lappend cstring_tests [dict create\ + type "PM "\ + msg "UN"\ + f7 punk::ansi::controlstring_PM\ + f7prefix "7bit ESC ^ secret "\ + f7suffix "safe"\ + f8 punk::ansi::controlstring_PM8\ + f8prefix "8bit \\x9e secret "\ + f8suffix "safe"\ + ] + lappend cstring_tests [dict create\ + type SOS\ + msg "NOT"\ + f7 punk::ansi::controlstring_SOS\ + f7prefix "7bit ESC X string "\ + f7suffix " hidden"\ + f8 punk::ansi::controlstring_SOS8\ + f8prefix "8bit \\x98 string "\ + f8suffix " hidden"\ + ] + lappend cstring_tests [dict create\ + type APC\ + msg "NOT"\ + f7 punk::ansi::controlstring_APC\ + f7prefix "7bit ESC _ APPLICATION PROGRAM COMMAND "\ + f7suffix " hidden"\ + f8 punk::ansi::controlstring_APC8\ + f8prefix "8bit \\x9f APPLICATION PROGRAM COMMAND "\ + f8suffix " hidden"\ + ] + + foreach test $cstring_tests { + set m [[dict get $test f7] [dict get $test msg]] + set hidden_width_m [punk::console::test_char_width $m] + set m8 [[dict get $test f8] [dict get $test msg]] + set hidden_width_m8 [punk::console::test_char_width $m8] + if {$hidden_width_m != 0 || $hidden_width_m8 != 0} { + if {$hidden_width_m == 0} { + set d "[a+ green bold][dict get $test f7prefix][a red]${m}[a][a+ green bold][dict get $test f7suffix][a]" + } else { + set d "[a+ yellow bold][dict get $test f7prefix][a red]$m[a][a+ yellow bold][dict get $test f7suffix][a]" + } + if {$hidden_width_m8 == 0} { + set d8 "[a+ green ][dict get $test f8prefix][a red]$m8[a][a+ green][dict get $test f8suffix][a]" + } else { + set d8 "[a+ yellow bold][dict get $test f8prefix][a red]$m8[a][a+ yellow bold][dict get $test f8suffix][a]" + } + append warningblock \n "WARNING: terminal doesn't hide all [dict get $test type] control strings: $d $d8" } - append warningblock \n "WARNING: terminal doesn't hide all [dict get $test type] control strings: $d $d8" } - } - if {![catch {punk::console::check::has_bug_legacysymbolwidth} result]} { - if {$result} { - append warningblock \n "WARNING: terminal has legacysymbolwidth bug - screen position for symbol reports 2 wide but displays 1 wide." - append warningblock \n $indent "Layout using 'legacy symbols for computing' affected." - append warningblock \n $indent "(e.g textblock frametype block2 unsupported)" - append warningblock \n $indent "This can cause extreme layout deformation when ANSI is present" - append warningblock \n $indent "In some cases unwanted spacing effects occur at a distance from the characters causing it" + if {![catch {punk::console::check::has_bug_legacysymbolwidth} result]} { + if {$result} { + append warningblock \n "WARNING: terminal has legacysymbolwidth bug - screen position for symbol reports 2 wide but displays 1 wide." + append warningblock \n $indent "Layout using 'legacy symbols for computing' affected." + append warningblock \n $indent "(e.g textblock frametype block2 unsupported)" + append warningblock \n $indent "This can cause extreme layout deformation when ANSI is present" + append warningblock \n $indent "In some cases unwanted spacing effects occur at a distance from the characters causing it" + } + } else { + append warningblock \n "WARNING: terminal unable to check for legacysymbolwidth bug. err:$result" } - } else { - append warningblock \n "WARNING: terminal unable to check for legacysymbolwidth bug. err:$result" - } - if {![catch {punk::console::check::has_bug_zwsp} result]} { - if {$result} { - append warningblock \n "WARNING: terminal has zero width space (\\u200b) bug - cursor position incremented when it shouldn't be." - append warningblock \n $indent "The zwsp may or may not be displayed. zwsp contributes to line length and wrapping point" + if {![catch {punk::console::check::has_bug_zwsp} result]} { + if {$result} { + append warningblock \n "WARNING: terminal has zero width space (\\u200b) bug - cursor position incremented when it shouldn't be." + append warningblock \n $indent "The zwsp may or may not be displayed. zwsp contributes to line length and wrapping point" + } + } else { + append warningblock \n "WARNING: terminal unable to check for zwsp bug. err:$result" } - } else { - append warningblock \n "WARNING: terminal unable to check for zwsp bug. err:$result" - } - set grapheme_support [punk::console::grapheme_cluster_support] - #mode, 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) - if {![dict size $grapheme_support] || [dict get $grapheme_support mode] eq "unsupported" } { - append warningblock \n "WARNING: terminal either doesn't support grapheme clusters, or doesn't report so via decmode 2027 query." - if {[dict size $grapheme_support] && [dict get $grapheme_support available]} { - append warningblock \n $indent "(but punk::console::grapheme_cluster_support has determined it is probably available)" - } - } else { - if {![dict get $grapheme_support available]} { - switch -- [dict get $grapheme_support mode] { - "unset" { - append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is off." - } - "permanently_unset" { - append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is permanently off." - } - "BAD_RESPONSE" { - append warningblock \n "WARNING: terminal doesn't seem to recognize decmode 2027 query. No grapheme cluster support." + set grapheme_support [punk::console::grapheme_cluster_support] + #mode, 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) + if {![dict size $grapheme_support] || [dict get $grapheme_support mode] eq "unsupported" } { + append warningblock \n "WARNING: terminal either doesn't support grapheme clusters, or doesn't report so via decmode 2027 query." + if {[dict size $grapheme_support] && [dict get $grapheme_support available]} { + append warningblock \n $indent "(but punk::console::grapheme_cluster_support has determined it is probably available)" + } + } else { + if {![dict get $grapheme_support available]} { + switch -- [dict get $grapheme_support mode] { + "unset" { + append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is off." + } + "permanently_unset" { + append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is permanently off." + } + "BAD_RESPONSE" { + append warningblock \n "WARNING: terminal doesn't seem to recognize decmode 2027 query. No grapheme cluster support." + } } } } - } - if {![string length $warningblock]} { - set text "No terminal warnings\n" - lappend chunks [list stdout $text] + if {![string length $warningblock]} { + set text "No terminal warnings\n" + lappend chunks [list stdout $text] + } } } topics - help { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm index fb5adce3..8450b2c8 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm @@ -108,7 +108,7 @@ tcl::namespace::eval punk::aliascore { # the aliascore::init will temporarily extend the exports list to do the import, and then reset the exports to how they were. set aliases [tcl::dict::create\ val ::punk::pipe::val\ - tstr ::punk::lib::tstr\ + tstr ::punk::args::lib::tstr\ list_as_lines ::punk::lib::list_as_lines\ lines_as_list ::punk::lib::lines_as_list\ linelist ::punk::lib::linelist\ @@ -116,7 +116,7 @@ tcl::namespace::eval punk::aliascore { pdict ::punk::lib::pdict\ plist {::punk::lib::pdict -roottype list}\ showlist {::punk::lib::showdict -roottype list}\ - rehash ::punk::rehash\ + rehash ::punk::auto_exec::rehash\ showdict ::punk::lib::showdict\ ansistrip ::punk::ansi::ansistrip\ stripansi ::punk::ansi::ansistrip\ @@ -228,7 +228,7 @@ tcl::namespace::eval punk::aliascore { } } if {!$opt_force && [llength $conflicts]} { - error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts" + error "punk::aliascore::init declined to create any aliases or imports because conflicts found. Use -force == 1 conflicts:\n [join $conflicts "\n "]" } set failed [list] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm index 5abc839d..cb6f796b 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm @@ -273,21 +273,68 @@ tcl::namespace::eval ::punk::args {} tcl::namespace::eval ::punk::args::helpers { variable PUNKARGS namespace export * - #proc B {} {return \x1b\[1m} ;#a+ bold - #proc N {} {return \x1b\[22m} ;#a+ normal - #proc I {} {return \x1b\[3m} ;#a+ italic - #proc NI {} {return \x1b\[23m} ;#a+ noitalic - proc I {} {punk::ansi::a+ italic} - proc B {} {punk::ansi::a+ bold} - proc N {} {punk::ansi::a+ normal} - proc NI {} {punk::ansi::a+ italic} + proc B {} {return \x1b\[1m} ;#a+ bold + proc N {} {return \x1b\[22m} ;#a+ normal + proc I {} {return \x1b\[3m} ;#a+ italic + proc NI {} {return \x1b\[23m} ;#a+ noitalic + #proc I {} {punk::ansi::a+ italic} + #proc B {} {punk::ansi::a+ bold} + #proc N {} {punk::ansi::a+ normal} + #proc NI {} {punk::ansi::a+ italic} lappend PUNKARGS [list { @id -id ::punk::args::helpers::example @cmd -name punk::args::helpers::example\ -summary\ {Display formatting for argdoc example text}\ -help\ - {Wrap } + {Wrap a block of text (e.g tcl code) in a box with optional syntax highlighting and title. + The text is processed with punk::lib::tstr to allow for command substitution and basic formatting, + but without any further dedenting (i.e it's assumed the text is already dedented appropriately + based on context). + The example function is intended for use in punk::args::define scripts to format example text in + the generated documentation, but it can be used in other contexts too. + + The box is a plain grey background with a lighter grey top and bottom border. + There are no side borders so the text can be copied without extra characters getting in the way, + These top and bottom bars are implemented using unicode block characters so the bars are still + visible when ANSI is stripped. + + ${[punk::args::helpers::example -title "[a+ term-yellow Term-blue] Example 1 [a]" { + #A sample of an example block of text with a garish title and some basic tcl syntax highlighting. + + proc test {args} { + puts "[a+ red]hello world[a]" + } + + }]} + + This was generated with code like the following in the punk::args::define script: + + ${[punk::args::helpers::example -syntax none -tstr 1 { + + ${[example -title "[a+ term-yellow Term-blue] Example 1 [a]" { + #A sample of an example block of text with a garish title and some basic tcl syntax highlighting. + + proc test {args} { + puts "[a+ red]hello world[a]" + } + + }]} + + }]} + + Here we eat our own dog food by nesting the example text within an ${[B]}example${[N]} call with -tstr 0 + to prevent the tstr processing of the text, and -syntax none to prevent the syntax highlighting. + This allows us to show the actual code used to generate ${[a+ term-yellow Term-blue]} Example 1 ${[a+ defaultbg][a]} above without having to use any + escaping backslashes etc that may show in the output. + + Note the slight indent of 2 characters on the left of the text in the example block. + This is intentional to show that the text is indented within the box, and as it's reasonably appealing + visually, explains why the -padright option defaults to padding with 2 chars on the right of the text. + + see also ${[B]}punk::args::lib::tstr${[N]} + + } @opts -padright -type integer -default 2 -help\ {Number of padding spaces to add on RHS of text block} @@ -295,9 +342,24 @@ tcl::namespace::eval ::punk::args::helpers { tcl\ " Very basic tcl syntax highlighting of braces,square brackets and comments." - -title -type string -default "" + } + -title -type string -default "" -help\ + {Optional title to display in the top border of the box. + The title is overlaid on the top bar which consists of lower-half block characters. + These block characters are set with foreground black and background silver, so the lower portion + of the bar appears silver. When the title is overlaid on top of this it gets the same colouring + so that the result is black text on siver background, but full height for the width of the title text. + + The title colour can be set to something other than the default black on silver by including ANSI in + the title text, but the bar on either side will still be silver. + e.g -title "[a+ term-yellow Term-blue]yellow on blue title[a]" + } + -tstr -type boolean -default 1 -help\ + {By setting this to false, we can disable tstr processing of the text. This means that the text will be + treated as a literal string and any tstr variable or command substitution will not be processed. + This can be useful if you want to include text that contains tstr formatting characters or commands + without them being interpreted.} -titlealign -type string -choices {left centre right} - } text -type string }] proc example {args} { @@ -317,10 +379,11 @@ tcl::namespace::eval ::punk::args::helpers { -syntax tcl\ -title ""\ -titlealign left\ + -tstr 1\ ] dict for {o v} $optlist { switch -- $o { - -padright - -syntax - -title - -titlealign {} + -padright - -syntax - -title - -titlealign - -notstr {} default { punk::args::parse $args withid ::punk::args::helpers::example return @@ -332,6 +395,7 @@ tcl::namespace::eval ::punk::args::helpers { set opt_syntax [dict get $opts -syntax] set opt_title [dict get $opts -title] set opt_titlealign [dict get $opts -titlealign] + set opt_tstr [dict get $opts -tstr] if {[string index $str 0] eq "\n"} { set str [string range $str 1 end] @@ -341,7 +405,10 @@ tcl::namespace::eval ::punk::args::helpers { } #example is intended to run from a source doc that has already been dedented appropriately based on context # - we don't want to further undent, hence -undent 0 - set str [uplevel 1 [list punk::lib::tstr -undent 0 -return string -eval 1 -allowcommands $str]] + if {$opt_tstr} { + #this is the default + set str [uplevel 1 [list punk::lib::tstr -undent 0 -return string -eval 1 -allowcommands $str]] + } #puts stderr ------------------- #puts $str #puts stderr ------------------- @@ -752,6 +819,10 @@ tcl::namespace::eval punk::args { argument name - only applies to final leader OR final value) (for options/flags this allows the opt-val pair or solo flag to appear multiple times - not necessarily contiguously) + -multipleunique (only valid if -multiple is true) + If true, when multiple values are stored against the same argument + name due to -multiple being true, the values must be unique. + If false, the same value can be stored multiple times. -choices {} A list of allowable values for an argument. The -default value doesn't have to be in the list. @@ -809,6 +880,24 @@ tcl::namespace::eval punk::args { If allows more than one choice the value is a list consisting of items in the choices made available through entries in -choices/-choicegroups. + -choicemultipleunique (default 0) + If choicemultiple is set to allow more than one choice, this + option specifies whether the choices must be unique within the + value list. If true, the same choice can't be selected more than + once. If false, the same choice can be selected multiple times. + -choicemultipleuniqueset (default 0) + Only applies if -choicemultiple is true and -multiple is true. + If choicemultiple is set to allow more than one choice, and + -multiple is true, this option specifies whether the sets of + choices must be unique across multiple occurrences of the argument. + If true, the same set of choices can't be selected more than once + across multiple occurrences of the multi-choice argument. + If false, the same set of choices can be selected multiple times + across multiple occurrences of the argument. + Without this option being set true, if -multiple is true and + -multipleunique is true, then the same set of choices in a + different order would be considered unique, which may not be + desirable. -unindentedfields {} for fields with multi-line values, tell the resolver to treat them as unindented. ie do no indent/unindent processing of @@ -902,8 +991,11 @@ tcl::namespace::eval punk::args { -choiceprefix 1\ -choicerestricted 1\ -choicemultiple {1 1}\ + -choicemultipleunique 0\ + -choicemultipleuniqueset 0\ -unindentedfields {}\ -multiple 0\ + -multipleunique 0\ -regexprepass {}\ -validationtransform {}\ -ensembleparameter 0\ @@ -918,8 +1010,11 @@ tcl::namespace::eval punk::args { -choiceprefix 1\ -choicerestricted 1\ -choicemultiple {1 1}\ + -choicemultipleunique 0\ + -choicemultipleuniqueset 0\ -unindentedfields {}\ -multiple 0\ + -multipleunique 0\ -regexprepass {}\ -validationtransform {}\ -prefix 1\ @@ -938,8 +1033,11 @@ tcl::namespace::eval punk::args { -choiceprefix 1\ -choicerestricted 1\ -choicemultiple {1 1}\ + -choicemultipleunique 0\ + -choicemultipleuniqueset 0\ -unindentedfields {}\ -multiple 0\ + -multipleunique 0\ -regexprepass {}\ -validationtransform {}\ ] @@ -1718,7 +1816,8 @@ tcl::namespace::eval punk::args { } -unindentedfields - -minsize - -maxsize - - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - + -choices - -choicegroups - -choicemultiple - + -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted { #review - only apply to certain types? tcl::dict::set tmp_optspec_defaults $k $v @@ -1807,7 +1906,8 @@ tcl::namespace::eval punk::args { -allow_ansi - -validate_ansistripped - -strip_ansi - - -multiple - + -multiple - -multipleunique - + -choicemultipleunique - -choicemultipleuniqueset - -prefix { #check is bool if {![string is boolean -strict $v]} { @@ -1823,6 +1923,7 @@ tcl::namespace::eval punk::args { -unindentedfields\ -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple -prefix\ + -multipleunique -choicemultipleunique -choicemultipleuniqueset\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ } error "punk::args::resolve - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" @@ -1936,7 +2037,10 @@ tcl::namespace::eval punk::args { -allow_ansi - -validate_ansistripped - -strip_ansi - - -multiple { + -multiple - + -multipleunique - + -choicemultipleunique - -choicemultipleuniqueset - + -optional { if {![string is boolean -strict $v]} { error "punk::args::resolve - invalid type of value '$v' for key '$k' in @leaders line. Must be boolean @id:$DEF_definition_id" } @@ -1961,6 +2065,7 @@ tcl::namespace::eval punk::args { -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ -unindentedfields\ -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -multipleunique -choicemultipleunique -choicemultipleuniqueset\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ -unnamed\ } @@ -2051,11 +2156,13 @@ tcl::namespace::eval punk::args { -typeranges { tcl::dict::set tmp_valspec_defaults -typeranges $v } - -optional - -allow_ansi - -validate_ansistripped - -strip_ansi - - -multiple { + -multiple - + -multipleunique - + -choicemultipleunique - -choicemultipleuniqueset - + -optional { if {![string is boolean -strict $v]} { error "punk::args::resolve - invalid type of value '$v' for key '$k' in @values line. Must be boolean @id:$DEF_definition_id" } @@ -2083,6 +2190,7 @@ tcl::namespace::eval punk::args { -unindentedfields\ -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -multipleunique -choicemultipleunique -choicemultipleuniqueset\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ -unnamed\ } @@ -2414,6 +2522,7 @@ tcl::namespace::eval punk::args { -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted - -choicelabels - -choiceinfo - -minsize - -maxsize - -nocase - -multiple - + -multipleunique - -choicemultipleunique - -choicemultipleuniqueset - -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - -regexprepass - -regexprefail - -regexprefailmsg { @@ -2519,6 +2628,7 @@ tcl::namespace::eval punk::args { -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted\ -unindentedfields\ -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -multipleunique -choicemultipleunique -choicemultipleuniqueset\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ -ensembleparameter\ ] @@ -9228,7 +9338,7 @@ tcl::namespace::eval punk::args { set v_test $c_check } set choice_in_list 0 - set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? + set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval could be a list when -choicemultiple? if {!$matches_default} { if {$choiceprefix} { #can we handle empty string as a choice? It should just work - REVIEW/test @@ -9277,6 +9387,7 @@ tcl::namespace::eval punk::args { set chosen $bestmatch set choice_in_list 1 } + puts ">>>>> chosen: $chosen bestmatch: $bestmatch for c_check: $c_check choices_test: $choices_test allchoices: $allchoices" } else { set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check] if {$chosen eq "" || $chosen in $choiceprefixreservelist} { @@ -9302,9 +9413,11 @@ tcl::namespace::eval punk::args { if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { #single choice allowed per clause-member if {$is_multiple} { + puts ">>>>> existing:'$existing' element_index:$element_index choice_index:$choice_idx chosen: $chosen" if {$clause_size == 1} { #no list wrapping of single element in $dname dict - so don't index into it with element_index - lset existing $element_index $chosen + #lset existing $element_index $chosen ;#wrong - test::punk::args test: choice_multiple_with_choiceprefix. + lset existing $clause_index $chosen } else { lset existing $clause_index $element_index $chosen } @@ -10626,10 +10739,29 @@ tcl::namespace::eval punk::args::lib { Placeholder Substitutions: \$\{$varName\} \$\{[myCommand]\} - (when -allowcommands flag is given)" + (myCommand is evaluated when -allowcommands flag is given) + + If any error occurs during placeholder evaluation, the original placeholder text + is substituted in the output and the error is included in the returned dict + (if -return dict is used). + " -allowcommands -default 0 -type none -help\ - "If -allowcommands is present, placeholder can contain commands - e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" + "If -allowcommands is present, placeholder commands are evaluated and subtituted. + e.g tstr -allowcommands { \$\{plaintext0 [lindex $var 1] plaintext2\} } + + if $var is {a b c}, the result will be \"plaintext0 b plaintext2 \" + if $var does not exist the result will be \"\$\{plaintext0 [lindex $var 1] plaintext2\} \" + with an error recorded in the returned dict if -return dict is used. + + NOTE: even if -allowcommands is not present, the placeholder text is still processed for variable + substitution and escape sequence processing, so the result will not be the raw placeholder text. + The result will be \"plaintext0 [lindex {a b c} 0] plaintext2 \" + + e.g + tstr -undent 0 -allowcommands { \$\{ \\$var\\[1\\] = [lindex $var 1]\}} + $var[1] = b + " + -undent -default 1 -type boolean -help\ "undent/dedent the template lines. The longest common prefix of whitespace is removed" @@ -10702,6 +10834,14 @@ tcl::namespace::eval punk::args::lib { which expects the placeholders as individual arguments" } + -raise_errors -default 0 -type boolean -help\ + "By default, if an error occurs during placeholder evaluation, the original placeholder text + is substituted in the output and the error is included in the returned dict (if -return dict is used). + If -raise_errors is set to 1, the template will be processed and a list of errors will be collected as + normal, but if any errors are present at the end of processing, a single error will be raised with a + summary of all errors that occurred. + This can be useful for debugging or when you want to ensure that any issues with placeholder evaluation + are immediately visible and not silently included in the output." -eval -default 1 -type boolean -help\ "Whether to evaluate the \$\{\} placeholders. When -return is string, -eval should generally be set to 1. @@ -10739,6 +10879,7 @@ tcl::namespace::eval punk::args::lib { -paramindents line\ -eval 1\ -return string\ + -raise_errors 0\ ] if {"-allowcommands" in $arglist} { set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] @@ -10754,9 +10895,9 @@ tcl::namespace::eval punk::args::lib { } } dict for {k v} $arglist { - set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] + set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval -raise_errors} $k] switch -- $fullk { - -indent - -undent - -paramindents - -return - -eval { + -indent - -undent - -paramindents - -return - -eval - -raise_errors { dict set opts $fullk $v } default { @@ -10781,6 +10922,7 @@ tcl::namespace::eval punk::args::lib { set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] if {$opt_return eq ""} { } + set opt_raise_errors [dict get $opts -raise_errors] set opt_eval [dict get $opts -eval] @@ -10871,6 +11013,14 @@ tcl::namespace::eval punk::args::lib { incr idx ;#expression incr } + if {$opt_raise_errors && [dict size $errors]} { + set einfo "" + dict for {i e} $errors { + append einfo "parameter $i error: $e" \n + } + error "punk::args::lib::tstr: Errors occurred during placeholder evaluation:\n$einfo" + } + if {$opt_return eq "dict"} { return [dict create template $textchunks params $params errors $errors] } @@ -11200,17 +11350,39 @@ tcl::namespace::eval punk::args::package { set pkgname [${pkgns}::package_name] set opt_return [dict get $OPTS -return] - set all_topics [${pkgns}::about_topics] + set defined_topics [${pkgns}::about_topics] if {![dict exists $received topic]} { - set topics $all_topics + set topics $defined_topics } else { # * represents all remaining topics not explicitly mentioned. set val_topics [dict get $values topic] ;#if -multiple is true, this is a list - set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] + #set explicit_topic_prefixes [lsearch -all -inline -exact -not $val_topics "*"] + set explicit_topics [list] + set requested_topics [list] + set defined_topics_lc [lmap t $defined_topics {string tolower $t}] + foreach et $val_topics { + #topics are case insensitive. We don't expect function names from about_topics to have variations differing only in case. + #todo - enforce this by only returning the last value from about_topics for each particular topic when there are duplicates differing only in case. + #(see punk::auto_execs for example. TODO -add to template or use helper function to enforce this when processing about_topics) + if {$et eq "*"} { + lappend requested_topics "*" + continue + } + + set fulltopic_lc [tcl::prefix::match -error "" $defined_topics_lc [string tolower $et]] + if {$fulltopic_lc eq ""} { + error "punk::args::package::standard_about topic '$et' does not match any defined topics: $defined_topics" + } else { + set resolved_topic [lsearch -inline -nocase $defined_topics $fulltopic_lc] + lappend explicit_topics $resolved_topic + lappend requested_topics $resolved_topic + } + } + set topics [list] - foreach t $val_topics { + foreach t $requested_topics { if {$t eq "*"} { - foreach a $all_topics { + foreach a $defined_topics { if {$a ni $explicit_topics} { lappend topics $a } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/auto_exec-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/auto_exec-0.1.0.tm index 22486038..662656cb 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/auto_exec-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/auto_exec-0.1.0.tm @@ -47,6 +47,45 @@ tcl::namespace::eval punk::auto_exec { set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline] } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id "::punk::auto_exec::rehash" + @cmd -name "punk::auto_exec::rehash"\ + -summary\ + "Update the hash table of autoexec commands cached in ::auto_execs."\ + -help\ + {Clear/refresh the autoexec commands in the ::auto_execs array. + + This is analogous to the 'rehash' command in shells such as csh, tcsh and zsh. + It updates the shell's hash table of executable commands. + + This can be useful after installing new software, adjusting the environment PATH directories, or (on windows) making + changes to the system that may affect file type associations and their associated commands, to ensure that the autoexec + commands are up to date with the current state of the system. + + If refresh is false (the default), then all autoexec commands are cleared and will re-register as commands are called. + If refresh is true, then all existing autoexec commands are re-registered by calling auto_execok for each of them again.} + @opts + @values -min 0 -max 1 + refresh -type boolean -default 0 -help\ + "Whether to re-register existing autoexec commands by calling auto_execok for each of them again." + }] + } + proc rehash {{refresh 0}} { + global auto_execs + if {!$refresh} { + unset -nocomplain auto_execs + } else { + set names [array names auto_execs] + unset -nocomplain auto_execs + foreach nm $names { + #auto_execok_windows $nm + auto_execok $nm + } + } + return + } + variable PUNKARGS lappend PUNKARGS [list { @id -id "::punk::auto_exec::shell_open_command" @@ -347,7 +386,7 @@ tcl::namespace::eval punk::auto_exec { if {!$new_chunk} { if {$current_chunk ne "" || $current_chunk eq "" && [lindex $quoted end]} { - #we add the current chunk to the result list if it's not empty, or if it is empty but is quoted (because in that case we want to preserve it as an empty argument). + #we add the current chunk to the result list if it's not empty, or if it is empty but is quoted (because in that case we want to preserve it as an empty argument). lappend result $current_chunk lappend quoted 0 set current_chunk {} @@ -564,15 +603,17 @@ tcl::namespace::eval punk::auto_exec { user-specific association is found. Returns a dict of dicts with toplevel keys for each shell verb (e.g open, runas) and values that are dicts with keys - ${$I}type${$NI} and ${$I}value${$NI} and ${$I}scope${$NI}, where - type is determined from the registry value type (e.g sz or expand_sz) - string is the raw command string from the registry - scope is either "user" or "system" depending on whether the value was found in the user-specific registry keys or - the system registry keys. + ${$I}type${$NI} and ${$I}value${$NI} and ${$I}scope${$NI}, where: + + ${$I}type${$NI} is determined from the registry value type (e.g sz or expand_sz) + + ${$I}string${$NI} is the raw command string from the registry + + ${$I}scope${$NI} is either \"user\" or \"system\" depending on whether the value was found in the user-specific + registry keys or the system registry keys. This is somewhat like the windows 'ftype' command except that the windows command only looks for the 'open' verb and - only looks up the system association and does not take into account any user-specific - overrides. + only looks up the system association and does not take into account any user-specific overrides. The file type can be looked up using the ${$B}assoc${$N} function in this package. @@ -587,40 +628,11 @@ tcl::namespace::eval punk::auto_exec { This can be looked up using the 'assoc' function in this package." }] } - #proc ftype {filetype} { - # package require registry - - # if {$filetype eq "cplfile"} { - # #special case for cplfile (associated with .cpl files) which doesn't follow the usual pattern of having the command string under shell\open\command, - # #but instead has it under HKEY_LOCAL_MACHINE\SOFTWARE\Classes\cplfile\shell\cplopen\command. - # #There doesn't seem to be any user-specific override for this file type - # #- but we will check for one under HKEY_CURRENT_USER\Software\Classes\cplfile\shell\cplopen\command anyway for consistency with the way we check - # #for user-specific overrides for other file types. - # set key [join [list HKEY_CURRENT_USER Software Classes cplfile shell cplopen command] "\\"] - # } else { - # set key [join [list HKEY_CURRENT_USER Software Classes $filetype shell open command] "\\"] - # } - # if {![catch {registry get $key ""} raw_assoc]} { - # set tp [registry type $key ""] - # return [dict create open [dict create type $tp string $raw_assoc]] - # } else { - # #e.g Python.File - # if {$filetype eq "cplfile"} { - # set key [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes cplfile shell cplopen command] "\\"] - # } else { - # set key [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $filetype shell open command] "\\"] - # } - # if {![catch {registry get $key ""} raw_assoc]} { - # set tp [registry type $key ""] - # return [dict create type $tp string $raw_assoc] - # } else { - # return [dict create type "" string ""] ;#no association found - # } - # } - #} proc ftype {filetype} { package require registry set resultdict [dict create] + #registry queries are case insensitive but some are keys are cased differently e.g Open vs open. + #when using the verb as a key in the output dict, we need to normalize so that it is useful for lookups. We'll use lowercase for that. #e.g Python.File set shellpath [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $filetype shell] "\\"] @@ -628,8 +640,6 @@ tcl::namespace::eval punk::auto_exec { foreach verb $shellverbs { set commandkey [join [list $shellpath $verb command] "\\"] if {![catch {registry get $commandkey ""} cmdstring]} { - #registry queryies are case insensitive but some are cased differently e.g Open vs open. - #when using the verb as a key in the output dict, we need to normalize so that it is useful for lookups. We'll use lowercase for that. set verb [string tolower $verb] set tp [registry type $commandkey ""] dict set resultdict $verb [dict create type $tp value $cmdstring scope system] @@ -649,7 +659,6 @@ tcl::namespace::eval punk::auto_exec { } } } - return $resultdict } @@ -671,9 +680,9 @@ tcl::namespace::eval punk::auto_exec::lib { #} -# == === === === === === === === === === === === === === === +# == === === === === === === === === === === === === === === # Sample 'about' function with punk::args documentation -# == === === === === === === === === === === === === === === +# == === === === === === === === === === === === === === === tcl::namespace::eval punk::auto_exec { tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase variable PUNKARGS @@ -682,8 +691,7 @@ tcl::namespace::eval punk::auto_exec { lappend PUNKARGS [list { @id -id "(package)punk::auto_exec" @package -name "punk::auto_exec" -help\ - "Package - Description" + "An autoexec_ok replacement for Tcl with support for windows file type associations and command string parsing." }] namespace eval argdoc { @@ -695,26 +703,34 @@ tcl::namespace::eval punk::auto_exec { #info commands results are returned in an arbitrary order (like array keys) set topic_funs [info commands [namespace current]::get_topic_*] set about_topics [list] + #use a dict to enforce last case-variation of a topic wins. + set case_dict [dict create] foreach f $topic_funs { set tail [namespace tail $f] - lappend about_topics [string range $tail [string length get_topic_] end] + set t [string range $tail [string length get_topic_] end] + set t_lc [string tolower $tail] + dict set case_dict $t_lc $t + } + dict for {lc t} $case_dict { + lappend about_topics $t } + #Adjust this function or 'default_topics' if a different order is required return [lsort $about_topics] } proc default_topics {} {return [list Description *]} # ------------------------------------------------------------- - # get_topic_ functions add more to auto-include in about topics + # get_topic_ functions add more to auto-include in about topics # ------------------------------------------------------------- proc get_topic_Description {} { - punk::args::lib::tstr [string trim { - package punk::auto_exec - description to come.. + punk::args::lib::tstr [string trim { + package punk::auto_exec + A replacement for Tcl's builtin autoexec_ok function. } \n] } proc get_topic_License {} { - return "" + return "BSD-3-Clause" } proc get_topic_Version {} { return "$::punk::auto_exec::version" @@ -730,22 +746,41 @@ tcl::namespace::eval punk::auto_exec { } return $contributors } - proc get_topic_custom-topic {} { - punk::args::lib::tstr -return string { - A custom - topic - etc - } + proc get_topic_Notes {} { + return [string trim { + This package primarily provides advanced features on the windows platform, but some functions such as 'rehash' are + useful on any platform. + + This package provides functions to look up windows file type associations and to parse command strings with placeholders + and environment variables, which can be used as a replacement for Tcl's autoexec_ok function in certain contexts. + + The 'assoc' function looks up the associated file type for a given file extension, taking into account both user-specific + and system-wide associations in the registry. + + The 'ftype' function looks up the shell verb command values for a given file type, also taking into account both user-specific + and system-wide associations in the registry. + + The 'shell_command_as_tcl_list' function processes a command string with placeholders and environment variables and returns a + Tcl list of command and arguments with the placeholders substituted according to the specified rules. + + } \n] } + #proc get_topic_custom-topic {} { + # punk::args::lib::tstr -return string { + # A custom + # topic + # etc + # } + #} # ------------------------------------------------------------- } # we re-use the argument definition from punk::args::standard_about and override some items set overrides [dict create] dict set overrides @id -id "::punk::auto_exec::about" - dict set overrides @cmd -name "punk::auto_exec::about" + dict set overrides @cmd -name "punk::auto_exec::about" dict set overrides @cmd -help [string trim [punk::args::lib::tstr { - About punk::auto_exec + About punk::auto_exec }] \n] dict set overrides topic -choices [list {*}[punk::auto_exec::argdoc::about_topics] *] dict set overrides topic -choicerestricted 1 @@ -761,7 +796,7 @@ tcl::namespace::eval punk::auto_exec { } } # end of sample 'about' function -# == === === === === === === === === === === === === === === +# == === === === === === === === === === === === === === === # ----------------------------------------------------------------------------- @@ -776,11 +811,11 @@ namespace eval ::punk::args::register { # ----------------------------------------------------------------------------- # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::auto_exec [tcl::namespace::eval punk::auto_exec { variable pkg punk::auto_exec variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/config-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/config-0.1.tm index 8d5a5dca..3d967541 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/config-0.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/config-0.1.tm @@ -15,13 +15,16 @@ tcl::namespace::eval punk::config { namespace eval punk {namespace export config} proc _homedir {} { - if {[info exists ::env(HOME)]} { - set home [file normalize $::env(HOME)] - } else { - #not available on 8.6? ok will error out here. - set home [file tildeexpand ~] - } - return $home + return [punk::nav::fs::~] ;#will work if HOME is not set. + #may return an error if no home directory can be determined + + #if {[info exists ::env(HOME)]} { + # set home [file normalize $::env(HOME)] + #} else { + # #not available on 8.6? ok will error out here. + # set home [file tildeexpand ~] + #} + #return $home } lappend PUNKARGS [list { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/du-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/du-0.1.0.tm index 6d2eb59f..ad27135d 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/du-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/du-0.1.0.tm @@ -1712,7 +1712,7 @@ namespace eval punk::du { set errors [dict create] foreach {k v} $args { switch -- $k { - -glob - -with_sizes - -with_times { + -glob - -filedebug - -patterndebug - -link_info - -with_sizes - -with_times - -types { dict set opts $k $v } default { @@ -1766,6 +1766,7 @@ namespace eval punk::du { set types_entry [list] set types_attribute [list] set types_permission [list] + set types_REQUIRED [list] foreach t $entry_and_attribute_types { switch -- $t { f - d - l - p - s - b - c { @@ -1775,16 +1776,46 @@ namespace eval punk::du { hidden - readonly { #these are all valid attributes lappend types_attribute $t + lappend types_REQUIRED $t } r - w - x { #these are all valid permissions lappend types_permission $t + lappend types_REQUIRED $t } default { error "du_dirlisting_generic unrecognized element in -types '$t'. Known types/attributes/permissions: f d l p s b c hidden readonly r w x" } } } + + set do_sizes_d [expr {"d" in $sized_types}] + set do_sizes_f [expr {"f" in $sized_types}] + set do_sizes_l [expr {"l" in $sized_types}] + set do_times_d [expr {"d" in $timed_types}] + set do_times_f [expr {"f" in $timed_types}] + set do_times_l [expr {"l" in $timed_types}] + if {[llength $types_entry] && "d" ni $types_entry} { + set skip_dirs 1 + } else { + set skip_dirs 0 + } + if {[llength $types_entry] && "f" ni $types_entry} { + set skip_files 1 + } else { + set skip_files 0 + } + if {[llength $types_entry] && "l" ni $types_entry} { + set skip_links 1 + } else { + set skip_links 0 + } + set trequire_hidden [expr {"hidden" in $types_REQUIRED}] + set trequire_readonly [expr {"readonly" in $types_REQUIRED}] + set trequire_executable [expr {"x" in $types_REQUIRED}] + set trequire_readable [expr {"r" in $types_REQUIRED}] + set trequire_writable [expr {"w" in $types_REQUIRED}] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- # The repeated globs are a source of slowness for this function. @@ -1813,56 +1844,42 @@ namespace eval punk::du { if {$opt_glob eq "*"} { #Note - multiple glob operations with restrictions seem to be faster than looped tests like 'file isdirectory' & 'file readlink' #set parent [lindex $folders $folderidx] - if {![llength $types_entry] || "d" in $types_entry} { - #we need to check directories for hidden attribute - as on windows, not all dotfiles are hidden, and not all hidden files are dotfiles - set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} * .*] - set dirs [glob -nocomplain -dir $folderpath -types d * .*] - } - if {![llength $types_entry] || "l" in $types_entry} { - set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} * .*] - set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique - } - if {![llength $types_entry] || "f" in $types_entry} { - set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} * .*] - set files [glob -nocomplain -dir $folderpath -types f * .*] - } + set globs [list *] } else { - if {![llength $types_entry] || "d" in $types_entry} { - #we need to check directories for hidden attribute - as on windows, not all dotfiles are hidden, and not all hidden files are dotfiles - set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} $opt_glob] - set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] - } - if {![llength $types_entry] || "l" in $types_entry} { - set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} $opt_glob] - set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique - } - if {![llength $types_entry] || "f" in $types_entry} { - set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} $opt_glob] - set files [glob -nocomplain -dir $folderpath -types f $opt_glob] - } + set globs [list $opt_glob] + } + #on windows this is a lot of separate globs to perform. Using the du_dirlisting_twapi is preferred for performance on windows - but this is a fallback and for testing. + #if {![llength $types_entry] || "d" in $types_entry} {} + if {!$skip_dirs} { + #we need to check directories for hidden attribute - as on windows, not all dotfiles are hidden, and not all hidden files are dotfiles + set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} {*}$globs] + set dirs [glob -nocomplain -dir $folderpath -types d {*}$globs] + } + if {!$skip_links} { + set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} {*}$globs] + set links [glob -nocomplain -dir $folderpath -types l {*}$globs] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique + } + if {!$skip_files} { + set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} {*}$globs] + set files [glob -nocomplain -dir $folderpath -types f {*}$globs] } } else { if {$opt_glob eq "*"} { - #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink' - #set parent [lindex $folders $folderidx] - #set dirs [glob -nocomplain -dir $folderpath -types d * .*] - #set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique - #set files [glob -nocomplain -dir $folderpath -types f * .*] set globs [list * .*] } else { set globs [list $opt_glob] - #set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] - #set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique - #set files [glob -nocomplain -dir $folderpath -types f $opt_glob] } - - if {![llength $types_entry] || "d" in $types_entry} { + #we need to classify our results - unlike a standard glob * operation which returns all entries in one collection. + #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink' + #however - these are still significantly slower than a single glob with no restrictions - so we want to minimize the number of globs we do + #- but we also want to avoid doing extra work classifying entries that we will end up ignoring based on types/attributes/permissions filters. + if {!$skip_dirs} { set dirs [glob -nocomplain -dir $folderpath -types d {*}$globs] } - if {![llength $types_entry] || "l" in $types_entry} { + if {!$skip_links} { set links [glob -nocomplain -dir $folderpath -types l {*}$globs] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique } - if {![llength $types_entry] || "f" in $types_entry} { + if {!$skip_files} { set files [glob -nocomplain -dir $folderpath -types f {*}$globs] } @@ -1957,6 +1974,7 @@ namespace eval punk::du { set types_entry [list] set types_attribute [list] set types_permission [list] + set types_REQUIRED [list] foreach t $entry_and_attribute_types { switch -- $t { f - d - l - p - s - b - c { @@ -2155,7 +2173,7 @@ namespace eval punk::du { set errors [dict create] if {"windows" eq $::tcl_platform(platform)} { if {$opt_glob eq "*"} { - set globs [list * .*] + set globs [list *] } else { set globs [list $opt_glob] } @@ -2295,6 +2313,13 @@ namespace eval punk::du { #we don't classify anything as 'flaggedhidden' on unix. #it is a convention for dotfiles rather than a flag - and we'll leave the distinction for the display library + set dirs {} + set hdirs {} + set files {} + set hfiles {} + set links {} + set hlinks {} + if {$opt_glob eq "*"} { set globs [list * .*] } else { @@ -2341,6 +2366,7 @@ namespace eval punk::du { if {"$ft" in $meta_types} { foreach path [set $lvar] { if {$has_winpath && [punk::winpath::illegalname_test $path]} { + #review. we don't want to fix the path - we just want classify it as nonportable set testpath [punk::winpath::illegalname_fix $path] if {![catch {file stat $testpath arrstat} errM]} { dict set meta_dict $path [dict create shorttype $ft {*}[array get arrstat]] @@ -2350,7 +2376,7 @@ namespace eval punk::du { dict set meta_dict $path [dict create shorttype $ft {*}$empty_stat_dict] } } else { - #caller may have read perm on the containing folder - but not on child item - so file stat could raise an error + #caller may have permission to read on the containing folder - but not on child item - so file stat could raise an error if {![catch {file stat $path arrstat} errM]} { dict set meta_dict $path [dict create shorttype $ft {*}[array get arrstat]] } else { @@ -2463,28 +2489,38 @@ namespace eval punk::du { } proc du_dirlisting_undecided {folderpath args} { - if {"windows" eq $::tcl_platform(platform)} { - #jmn disable twapi - #tailcall du_dirlisting_generic $folderpath {*}$args - - package require zzzload - set loadstate [zzzload::pkg_require twapi] - if {$loadstate ni [list loading failed]} { - #either already loaded by zzload or ordinary package require - package require twapi ;#should be fast once twapi dll loaded in zzzload thread - set ::punk::du::has_twapi 1 - punk::du::active::set_active_function du_dirlisting du_dirlisting_twapi - tailcall du_dirlisting_twapi $folderpath {*}$args - } else { - if {$loadstate eq "failed"} { - puts stderr "punk::du defaulting to du_dirlisting_generic because twapi load failed" - punk::du::active::set_active_function du_dirlisting du_dirlisting_generic + switch -- $::tcl_platform(platform) { + windows { + #jmn disable twapi + #tailcall du_dirlisting_generic $folderpath {*}$args + + package require zzzload + set loadstate [zzzload::pkg_require twapi] + + if {$loadstate ni [list loading failed]} { + #either already loaded by zzload or ordinary package require + package require twapi ;#should be fast once twapi dll loaded in zzzload thread + set ::punk::du::has_twapi 1 + punk::du::active::set_active_function du_dirlisting du_dirlisting_twapi + tailcall du_dirlisting_twapi $folderpath {*}$args + } else { + if {$loadstate eq "failed"} { + puts stderr "punk::du defaulting to du_dirlisting_generic because twapi load failed" + punk::du::active::set_active_function du_dirlisting du_dirlisting_generic + } + tailcall du_dirlisting_generic $folderpath {*}$args } - tailcall du_dirlisting_generic $folderpath {*}$args } - } else { - punk::du::active::set_active_function du_dirlisting du_dirlisting_unix - tailcall du_dirlisting_unix $folderpath {*}$args + default { + #todo - macOS specific optimizations? e.g using macos metadata to determine hidden/readonly/system flags etc? + #macOS uses a case-insensitive filesystem by default like windows. + + #punk::du::active::set_active_function du_dirlisting du_dirlisting_unix + #tailcall du_dirlisting_unix $folderpath {*}$args + + punk::du::active::set_active_function du_dirlisting du_dirlisting_generic + tailcall du_dirlisting_generic $folderpath {*}$args + } } } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm index e816e1ef..9de4a33d 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm @@ -127,9 +127,14 @@ namespace eval punk::mix::util { foreach p $finalpaths { if {$has_winlnk && [file extension $p] eq ".lnk"} { set resolve_info [punk::winlnk::resolve $p] - set resolved [dict get $resolve_info link_target] + set resolved [dict get $resolve_info link_roottarget] if {$resolved ne ""} { - lappend resolved_finalpaths $resolved + if {[dict exists $resolve_info stringdata command_line_arguments]} { + puts stderr "link $p has arguments. Will cat the .lnk file itself rather than the root target." + lappend resolved_finalpaths $p + } else { + lappend resolved_finalpaths $resolved + } } else { lappend resolved_finalpaths $p } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm index 24dfad86..6d877c5f 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm @@ -157,6 +157,177 @@ tcl::namespace::eval punk::nav::fs { #[list_begin definitions] + #only lookup user_home once per interp or process + #It can be slightly expensive (for example involving network calls on windows domains) + variable user_home_cache + set user_home_cache "" + + #tilde + #These aliases work fine for interactive use - but the result is always a string internal-rep + #interp alias {} ~ {} file join $::env(HOME) ;#HOME must be capitalized to work cross platform (lowercase home works on windows - but probably not elsewhere) + #interp alias {} ~ {} apply {args {file join $::env(HOME) $args}} + namespace eval argdoc { + punk::args::define { + @id -id ::punk::nav::fs::~ + @cmd -name "punk::nav::fs::~"\ + -summary\ + "Return user's home directory as the process sees it"\ + -help\ + "Return the user's home directory path as the process sees it. + + (This is not always the same as ::env(HOME)) + + With additional arguments, return the path obtained by joining + the user's home directory with the supplied arguments. + + usage e.g + cd [~] + (change to user's home) + .// [~] .config + (change to .config directory within the user's home + and list contents.) + equivalently: + gohome .config + (gohome uses the output of ~ to determine the home directory) + + If the home directory cannot be determined due to the environment + in which the process is running, an error will be raised, as returning + an empty string is not a useful result and can cause issues if used as a path. + " + @opts + @values -min 0 -max -1 + arg -type any -optional 1 -multiple 1 + } + } + proc ~ {args} { + #review - HOME may be undefined or have been set to another value by other tools or the parent process. + #The process may even be running in a context where there is no home directory - e.g a container with no users, or a system service context. + #(we may be in a safe interp - which generally won't have env vars or filesystem access) + variable user_home_cache + if {$user_home_cache ne ""} { + set hdir $user_home_cache + #we still need to process args to join them to the home directory - but we can skip all the work of determining the home directory again. + } else { + set hdir "" + + if {[catch {auto_execok whoami} whoami_exe]} { + set whoami_exe "" + } + if {$whoami_exe eq ""} { + #try env USER or USERNAME - these are commonly set to the username on many platforms - but may not be set in all contexts. + if {[info exists ::env(USER)]} { + set user $::env(USER) + } elseif {[info exists ::env(USERNAME)]} { + set user $::env(USERNAME) + } else { + set user "" + } + } else { + #set user [exec {*}$whoami_exe] + if {[catch {exec {*}$whoami_exe} user]} { + set user "" + } + } + if {[string trim $user] ne ""} { + #normalize user for use with 'file tildeexpand ~' + #on windows, whoami may return DOMAIN\USER + #for tildeexpand to work, we need to convert this to USER@DOMAIN + if {"windows" eq $::tcl_platform(platform)} { + set parts [split $user "\\"] + #we expect only 1 or 2 parts + if {[llength $parts] == 2} { + lassign $parts domain username + + #if we use username@domain format - we get the domain controller's view of our home directory - which can be different from the local machine's view of our home directory. + #e.g file tildeexpand ~jnoble@corp can return a local non existant path like c:/users/jnoble + #but it may be c:/users/jnoble.corp - or c:/users/something_else_entirely depending on how the local machine is configured. + #It may be that the domain controller is correct if it returns a network path like \\server\users\jnoble ?? + #Network paths are not necessarily the preferred practive as of 2026 - but may still exist. + #Microsoft is encouraging the use of cloud systems - but it it unknown at this stage what sort of paths can be returned. + + #REVIEW + + set domainuser "$username@$domain" + #we can run file tildeexpand with username@domain and test if the path is writable + #this reduces the possibility that there happens to be a local user with the same name as the domain user - which would cause us to get the wrong home directory. + if {![catch {file tildeexpand ~$domainuser} path]} { + if {[file writable $path]} { + set user $domainuser + set hdir $path ;#set hdir so we don't re-lookup below. + } + } + if {$hdir eq ""} { + #for now we will use the unqualified username. + set user $username + } + + } elseif {[llength $parts] == 1} { + set user [lindex $parts 0] + } else { + #unexpected format - emit warning + puts stderr "Warning: Unexpected format of username '$user' returned by whoami. Expected format 'DOMAIN\\USER' or 'USER'. Unable to determine home directory for this user." + set user "" + } + } + + #only enter this branch if hdir wasn't resolved above for windows domain user. + if {$hdir eq "" && $user ne ""} { + #we use file tildeexpand ~user because the intention is stated in the tcl source as: + #* the intent is to retrieve (as on Unix) the system's view + #* of the home irrespective of environment settings of HOME + #* and USERPROFILE. + # - this aligns with our intention here. + if {![catch {file tildeexpand ~$user} path]} { + set hdir [punk::valcopy $path] + } else { + #tcl <= 8.6 may not have file tildeexpand. + #we now have no option but to rely on environment variables - which may not be set or may be set to an incorrect value + #as tcl <= 8.6 needs to be supported - but isn't the primary target we will allow this fallback - but raise a warning as this is not ideal. + puts stderr "punk::nav::fs::~ Warning: Unable to determine home directory for user '$user' using 'file tildeexpand ~$user'. Falling back to environment variables, which may not be set or may be incorrect. Consider upgrading to Tcl 9.0 or later for improved reliability." + if {"windows" eq $::tcl_platform(platform)} { + if {[info exists ::env(USERPROFILE)]} { + set hdir [punk::valcopy $::env(USERPROFILE)] + } else { + set hdir "" + } + } else { + if {[info exists ::env(HOME)]} { + set hdir [punk::valcopy $::env(HOME)] + } else { + set hdir "" + } + } + } + } + } + } + + if {$hdir eq ""} { + error "punk::nav::fs::~ Unable to determine home directory for user '$user'. Consider upgrading to Tcl 9.0 or later for improved reliability in home directory detection." + } + + file pathtype $hdir ;#flips internal-rep to path + if {![file isdirectory $hdir]} { + #file isdirectory should also return true if the path exists and is a symlink to a directory - but if it doesn't exist at all - or is a file - then we have a problem. + error "punk::nav::fs::~ Determined home directory path '$hdir' does not exist (or is not a directory)." + } else { + if {![file readable $hdir]} { + error "punk::nav::fs::~ Determined home directory path '$hdir' is not readable." + } + } + + set user_home_cache $hdir ;#cache only the home directory. + + set d $hdir + #use the file join 2-arg optimisation to avoid losing path-rep - probably doesn't give any advantage on all Tcl versions + #review - for what versions does/did the 2-arg version of file join not just return a string? + foreach a $args { + set d [file join $d $a] + } + file pathtype $d + return [punk::valcopy $d] + } + punk::args::define { @id -id ::punk::nav::fs::d/ @cmd -name punk::nav::fs::d/ -help\ @@ -624,9 +795,11 @@ tcl::namespace::eval punk::nav::fs { return $result } + + #---------------------------------------------------- punk::args::define { - @id -id ::punk::nav::fs::d/new - @cmd -name punk::nav::fs::d/new\ + @id -id ::punk::nav::fs::newdir + @cmd -name punk::nav::fs::newdir\ -summary\ "Create directory or directories at the specified path(s)."\ -help\ @@ -662,9 +835,9 @@ tcl::namespace::eval punk::nav::fs { created for some reason (e.g other filesystem error) then an error will be raised and processing of any remaining paths will be aborted." } - #todo - synchronize overall behaviour of d/new with that of n/new (for namespaces) - proc d/new {args} { - set argd [punk::args::parse $args withid ::punk::nav::fs::d/new] + #todo - synchronize overall behaviour of newdir with that of newns (for namespaces) + proc newdir {args} { + set argd [punk::args::parse $args withid ::punk::nav::fs::newdir] lassign [dict values $argd] leaders opts values received set paths [dict get $values path] set allow_nonportable [dict exists $received -nonportable] @@ -678,12 +851,12 @@ tcl::namespace::eval punk::nav::fs { set error_paths [list] foreach p $paths { if {!$allow_nonportable && [punk::winpath::illegalname_test $p]} { - #error "punk::nav::fs::d/new Path '$p' is not portable and may not be created without -nonportable option" + #error "punk::nav::fs::newdir Path '$p' is not portable and may not be created without -nonportable option" lappend error_paths [list $p "Path '$p' is not portable and may not be created without -nonportable option"] continue } if {[string first \0 $p] != -1} { - #error "punk::nav::fs::d/new Path '$p' contains null character which is not allowed" + #error "punk::nav::fs::newdir Path '$p' contains null character which is not allowed" lappend error_paths [list $p "Path '$p' contains null character which is not allowed"] continue } @@ -699,7 +872,7 @@ tcl::namespace::eval punk::nav::fs { set parent [file dirname $parent] } if {![file writable $parent]} { - #error "punk::nav::fs::d/new Cannot create directory '$fullpath' as parent '$parent' is not writable" + #error "punk::nav::fs::newdir Cannot create directory '$fullpath' as parent '$parent' is not writable" lappend error_paths [list $fullpath "Cannot create directory '$fullpath' as parent '$parent' is not writable"] continue } @@ -713,7 +886,7 @@ tcl::namespace::eval punk::nav::fs { set m [lindex $e 1] append path_error_display " Path: '$p' Error: $m\n" } - error "punk::nav::fs::d/new One or more supplied paths were invalid or not writable:\n$path_error_display" + error "punk::nav::fs::newdir One or more supplied paths were invalid or not writable:\n$path_error_display" } set num_created 0 @@ -730,17 +903,56 @@ tcl::namespace::eval punk::nav::fs { incr num_created } if {$error_string ne ""} { - error "punk::nav::fs::d/new $error_string\n$num_created directories out of [llength $fullpath_list] were created successfully before the error was encountered." + error "punk::nav::fs::newdir $error_string\n$num_created directories out of [llength $fullpath_list] were created successfully before the error was encountered." } #display summaries of created directories (which may have already existed) by reusing d/ to get info on them. set query_paths [lmap v $paths {string cat $v "/*"}] d/ / {*}$query_paths } + #---------------------------------------------------- + - #todo use unknown to allow d/~c:/etc ?? - proc d/~ {args} { - set home $::env(HOME) + punk::args::define { + @id -id ::punk::nav::fs::lib::gohome + @cmd -name punk::nav::fs::lib::gohome\ + -summary\ + "Navigate to a path relative to the current user's home directory."\ + -help\ + "Navigate to a path relative to the user's home directory. + + This may usually correspond to the HOME environment variable, but some + tools may have pointed HOME elsewhere, so the home directory is determined + based on the current user as determined using the whoami command, which is + almost universally available on platforms that Tcl runs on, and should be + unaffected by any changes to environment variables. + + This is a convenience function for quickly navigating to commonly used + locations within the home directory, without having to type out the full + path or use environment variables. + + Like the './' command, this navigates to the folder and then lists the sub-directories, + with a summary of the number of sub-directories and files, and total file size in bytes. + + " + @values -min 1 -max -1 + path -type string -optional 1 -multiple 1 -help\ + "Path relative to home directory to navigate to. + If the path does not exist, or is not a directory, then an error will be raised. + Examples: + gohome - will navigate to $HOME + (equivalent: gohome .) + gohome subdir1/subdir2 - will navigate to $HOME/subdir1/subdir2 + (equivalent: gohome subdir1 subdir2) + gohome subdir1 - will navigate to $HOME/subdir1 + + An absolute path is also accepted, but then the navigation is not relative to the home + directory and is effectively just a normal navigation to the specified path. + (equivalent to using ./ ) + " + } + proc gohome {args} { + set home [punk::nav::fs::~] set target [file join $home {*}$args] if {![file isdirectory $target]} { error "Folder $target not found" @@ -1731,10 +1943,11 @@ tcl::namespace::eval punk::nav::fs { if {![catch {package require punk::winlnk}]} { set target_type "file" ;#default/fallback - set shortcutinfo [punk::winlnk::resolve $fname] - if {[dict exists $shortcutinfo link_target]} { + set shortcutinfo [punk::winlnk::resolve $fname] ;#will always return a dict. Will only contain error key if there was an error. + + if {[dict exists $shortcutinfo link_roottarget]} { set is_valid_lnk 1 - set tgt [dict get $shortcutinfo link_target] + set root_tgt [dict get $shortcutinfo link_roottarget] set link_target_type [dict get $shortcutinfo target_type] switch -- $link_target_type { file { @@ -1744,12 +1957,12 @@ tcl::namespace::eval punk::nav::fs { set target_type "directory" } unknown { - #fall back to checking attributes and filesystem if we have a link_target but no target_type - if {[file exists $tgt]} { + #fall back to checking attributes and filesystem if we have a link_roottarget but no target_type + if {[file exists $root_tgt]} { #file type could return 'link' - we will use isfile/isdirectory - if {[file isfile $tgt]} { + if {[file isfile $root_tgt]} { set target_type file - } elseif {[file isdirectory $tgt]} { + } elseif {[file isdirectory $root_tgt]} { set target_type directory } else { set target_type file ;## ? @@ -1761,26 +1974,32 @@ tcl::namespace::eval punk::nav::fs { } } } else { - #no link_target - probably an ordinary file - but there could have been some other error in reading the binary windows lnk format. + #no link_roottarget - probably an ordinary file - but there could have been some other error in reading the binary windows lnk format. set is_valid_lnk 0 } if {$is_valid_lnk} { switch -- $target_type { file { set display [dict get $fdict display] - set display "$fshortcut_style$display (shortcut $tgt)" ;# + if {[dict exists $shortcutinfo stringdata command_line_arguments]} { + set display "$fshortcut_style$display (shortcut to $root_tgt [dict get $shortcutinfo stringdata command_line_arguments])" + } else { + set display "$fshortcut_style$display (shortcut $root_tgt)" ;# + } dict set fdict display $display lappend finfo_plus $fdict } directory { #target of link is a dir - for display/categorisation purposes we want to see it as a dir #will be styled later based on membership of dir_shortcuts + #review: we shouldn't see a link to a dir that also has command_line_arguments + #- but if we do, we will just ignore the command_line_arguments for now and treat as a directory shortcut. lappend dirs $fname lappend dir_shortcuts $fname } } } else { - #we were unable to get link_target - but we still need to check if it failed the header check (then assume not intended to be a windows shell lnk) or for some other reason. + #we were unable to get link_roottarget - but we still need to check if it failed the header check (then assume not intended to be a windows shell lnk) or for some other reason. if {[dict exists $shortcutinfo error]} { if {[dict get $shortcutinfo error] ne "lnk_header_check_failed"} { #Presumably there is a valid lnk header, but some unexpected error occurred - show it in the display for the file @@ -1794,9 +2013,10 @@ tcl::namespace::eval punk::nav::fs { lappend finfo_plus $fdict } } else { - #shouldn't ever happen. If no error, then there should have been a link_target + #shouldn't ever happen. If no error, then there should have been a link_roottarget #report and move on - puts stderr "Unexpected error in result of parsing binary format for $fname" + puts stderr "Unexpected error in result of parsing binary format for $fname." + puts stderr "Result was [showdict $shortcutinfo]" lappend finfo_plus $fdict } } @@ -2079,6 +2299,7 @@ tcl::namespace::eval punk::nav::fs::system { } +interp alias {} ~ {} punk::nav::fs::~ interp alias {} ./ {} punk::nav::fs::d/ / interp alias {} d/ {} punk::nav::fs::d/ / interp alias {} .// {} punk::nav::fs::d/ // @@ -2093,10 +2314,12 @@ interp alias {} dirfiles {} punk::nav::fs::dirfiles interp alias {} dirfiles_dict {} punk::nav::fs::dirfiles_dict interp alias {} fglob {} punk::nav::fs::fglob -interp alias {} ./new {} punk::nav::fs::d/new -interp alias {} d/new {} punk::nav::fs::d/new -interp alias {} ./~ {} punk::nav::fs::d/~ -interp alias {} d/~ {} punk::nav::fs::d/~ +interp alias {} newdir {} punk::nav::fs::newdir + +#this also conflicts with auto_cd as there could be a local folder (or file) called ~. +interp alias {} gohome {} punk::nav::fs::gohome + +#review interp alias {} x/ {} punk::nav::fs::x/ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/ns-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/ns-0.1.0.tm index 16cb13a1..6a336808 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/ns-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/ns-0.1.0.tm @@ -94,7 +94,8 @@ tcl::namespace::eval punk::nav::ns { if {[llength $ensemble_info] > 0} { #this namespace happens to match ensemble command. #todo - keep cache of encountered ensembles from commands.. and examine namespace in the configure info. - set ns_display "\n[a+ yellow bold]$ns_current (ensemble)[a+]" + #don't rely on a+ alias here. + set ns_display "\n[punk::ansi::a+ yellow bold]$ns_current (ensemble)[punk::ansi::a+]" } } } @@ -103,11 +104,86 @@ tcl::namespace::eval punk::nav::ns { return $out } - #create possibly nested namespace structure - but only if not already existant - proc n/new {args} { + #create possibly nested namespace structure(s) - todo: allow specifying namespaces or which already or partially already exist. + #todo - sync with newdir behaviour. + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::punk::nav::ns::newns + @cmd -name punk::nav::ns::newns\ + -summary\ + "Create namespace or namespaces at the specified path(s)."\ + -help\ + "This command creates namespaces at the specified path(s). + If any part of the specified path does not exist, then it will be created as well. + If a specified path already exists, then it will be left as-is and no error will be raised. + + A summary line is returned for each created namespace, with the full path of the created + namespace and a status line indicating the number of child namespaces, commands and vars in + the namespace if it already existed (or showing 0 for all if it was just created). + (summary incomplete - todo)" + -force -type none\ + -help\ + "Allows creation of namespaces which may be unwise/problematic, such as empty string + or namespaces with leading colons. + Use with caution and only when you know what you are doing. + If -force is not supplied, then an error will be raised if any supplied + path is problematic and no namespaces will be created." + @values -min 1 -max -1 -type string + path -type string -multiple 1 -optional 0 -help\ + "Path(s) (possibly with namespace separator ::) to create. + Can be absolute or relative to current namespace. + If any path is rejected, then no namespaces will be created. + + If a namespace or part of a namespace already exists, then it will be left as-is and no + error will be raised. + + If despite passing the name tests, a namespace cannot be created for some reason then an + error will be raised and processing of any remaining paths will be aborted." + }] + } + proc newns {args} { + set argd [punk::args::parse $args withid ::punk::nav::ns::newns] + lassign [dict values $argd] _leaders opts values _received + if {[dict exists $opts -force]} { + set opt_force [dict get $opts -force] + } else { + set opt_force 0 + } + set paths [dict get $values path] + + variable ns_current + + #todo: like newdir we want to try to perform an all-or-nothing operation - so first validate all namespaces to be created before creating any of them. + + set ns [lindex $paths 0] ;#temporary - full implementation will loop through $paths. + set is_absolute [string match ::* $ns] + if {$is_absolute} { + set nspath $ns + } else { + if {[string match :* $ns]} { + #todo - disallow by default and require flag to force. + #we also should disallow by default ::: (or any odd multiple? perhaps even :::: for empty ns should require -force) in between segments. + puts stderr "newns WARNING namespace with leading colon '$ns' is likely to have unexpected results" + } + set nspath [nsjoin $ns_current $ns] + } + + set ns_exists [nseval [nsprefix $nspath] [list ::tcl::namespace::exists [nstail $nspath] ]] + + if {$ns_exists} { + error "Namespace $nspath already exists" + } + #tcl::namespace::eval [nsprefix $nspath] [list tcl::namespace::eval [nstail $nspath] {}] + nseval [nsprefix $nspath] [list ::tcl::namespace::eval [nstail $nspath] {}] + + #display summaries of created directories (which may have already existed) by reusing d/ to get info on them. + set query_paths [lmap v $paths {string cat $v "::*"}] + ns/ / {*}$query_paths + } + proc newns_old {args} { variable ns_current if {![llength $args]} { - error "usage: :/new \[ ...\]" + error "usage: newns \[ ...\]" } set a1 [lindex $args 0] set is_absolute [string match ::* $a1] @@ -115,7 +191,7 @@ tcl::namespace::eval punk::nav::ns { set nspath [nsjoinall {*}$args] } else { if {[string match :* $a1]} { - puts stderr "n/new WARNING namespace with leading colon '$a1' is likely to have unexpected results" + puts stderr "newns WARNING namespace with leading colon '$a1' is likely to have unexpected results" } set nspath [nsjoinall $ns_current {*}$args] } @@ -130,6 +206,7 @@ tcl::namespace::eval punk::nav::ns { n/ $nspath } + #nn/ ::/ nsup/ - back up one namespace level proc nsup/ {v args} { variable ns_current @@ -160,14 +237,13 @@ tcl::namespace::eval punk::nav::ns { interp alias {} n/ {} punk::nav::ns::ns/ / interp alias {} n// {} punk::nav::ns::ns/ // interp alias {} n/// {} punk::nav::ns::ns/ /// -interp alias {} n/new {} punk::nav::ns::n/new +interp alias {} newns {} punk::nav::ns::newns interp alias {} nn/ {} punk::nav::ns::nsup/ / interp alias {} nn// {} punk::nav::ns::nsup/ // if 0 { -#we can't have ::/ without just plain / which is confusing. interp alias {} :/ {} punk::nav::ns::ns/ / interp alias {} :// {} punk::nav::ns::ns/ // -interp alias {} :/new {} punk::nav::ns::n/new +#we can't have ::/ without just plain / which is confusing. interp alias {} ::/ {} punk::nav::ns::nsup/ / interp alias {} ::// {} punk::nav::ns::nsup/ // } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm index 883f82de..b90c3b3b 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm @@ -3416,8 +3416,8 @@ y" {return quirkykeyscript} lappend usageinfo $c set found_documentation 1 } - #todo - alias to an alias - #e.g n/new jjj + #todo? - alias to an alias + #e.g newns jjj # interp alias "" ::jjj::corp2 "" ::corp #todo -pseudocode #cmdwhich id diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/winlnk-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/winlnk-0.1.1.tm index 7ad2ba89..6c31f56a 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/winlnk-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/winlnk-0.1.1.tm @@ -75,6 +75,10 @@ tcl::namespace::eval punk::winlnk { #[para] Core API functions for punk::winlnk #[list_begin definitions] + #todo - review internal API. + #A lot of these functions accept the raw contents of a .lnk file. + #It may make sense to use an OO approach to avoid reparsing of contents when calling multiple functions on the same .lnk file. + variable magic_HeaderSize "0000004C" ;#HeaderSize MUST equal this variable magic_LinkCLSID "00021401-0000-0000-C000-000000000046" ;#LinkCLSID MUST equal this @@ -853,14 +857,14 @@ tcl::namespace::eval punk::winlnk { set suffix_path "" set linkinfocontent [dict get $linkinfo_content_dict content] set next_start [dict get $linkinfo_content_dict next_start] ;#location of section following LinkInfo (Location information) - this will be the Data Strings. - set link_target "" + set link_roottarget "" set linkfields [dict create] if {$linkinfocontent ne ""} { set linkfields [LinkInfo_get_fields $linkinfocontent] set localbase_path [dict get $linkfields localbasepath] set suffix_path [dict get $linkfields commonpathsuffix] if {"windows" eq $::tcl_platform(platform)} { - set link_target [file join $localbase_path $suffix_path] + set link_roottarget [file join $localbase_path $suffix_path] } else { #review - calling mount and parsing its output every time we parse a .lnk file makes this slow on large folders with .lnk files # - we may want to cache the results of mount for some period of time or until we detect a change in the system's mounts (e.g. by monitoring /proc/mounts for changes or using a filesystem watcher on /mnt) @@ -868,24 +872,24 @@ tcl::namespace::eval punk::winlnk { if {[regexp {([a-zA-Z]):\\(.*)} $localbase_path _match drive_letter tail]} { set localbase_path [string map {\\ /} $localbase_path] set tail [string trimleft [string map {\\ /} $tail] /] - set link_target "" + set link_roottarget "" #shortcut basepath is a windows path with drive letter - try to resolve it on unix by looking for a corresponding mount from fstab or a point under /mnt set mountinfo [exec mount] foreach line [split $mountinfo "\n"] { #review - a more specific mount target might exist that includes the drive letter as part of the mount point name and is a longer prefix of the localbase_path #- we should probably look for the longest prefix match rather than just the drive letter if {[regexp -nocase -- [string cat ^$drive_letter {:\\\s+on\s+(\S+)}] $line _match mount_point]} { - set link_target [file join $mount_point $tail $suffix_path] + set link_roottarget [file join $mount_point $tail $suffix_path] break } } - if {$link_target eq ""} { + if {$link_roottarget eq ""} { #review - under what circumstances could this happen? If the drive letter doesn't match any mount points, then /mnt/drive_letter should generally already have been found above above # - However, it may be possible for /mnt/drive_Letter to still exist even if it's not reflected in the output of mount or the output of mount is in an unexpected format. #nothing in mount result matches the drive letter - try looking for a mount point under /mnt with the drive letter as the name if {[file exists /mnt/$drive_letter]} { - set link_target [file join /mnt/$drive_letter $tail $suffix_path] + set link_roottarget [file join /mnt/$drive_letter $tail $suffix_path] } else { if {$drive_letter eq [string tolower $drive_letter]} { set op_drive_letter [string toupper $drive_letter] @@ -893,20 +897,20 @@ tcl::namespace::eval punk::winlnk { set op_drive_letter [string tolower $drive_letter] } if {[file exists /mnt/$op_drive_letter]} { - set link_target [file join /mnt/$op_drive_letter $tail $suffix_path] + set link_roottarget [file join /mnt/$op_drive_letter $tail $suffix_path] } else { #leave as is except for backslashes converted to forward #- probably won't resolve correctly unless the unix system has a folder named drive_letter: in the current folder with a copy of the original filestructure. - set link_target [file join $localbase_path $suffix_path] + set link_roottarget [file join $localbase_path $suffix_path] } } } else { - #shortcut basepath is a windows path with drive letter and we found a matching mount point - link_target is set to the resolved path + #shortcut basepath is a windows path with drive letter and we found a matching mount point - link_roottarget is set to the resolved path } } else { #shortcut basepath doesn't match expected windows path format - just join it with the suffix and hope for the best #could be something like a network path or it could be something else entirely - set link_target [file join $localbase_path $suffix_path] + set link_roottarget [file join $localbase_path $suffix_path] } } } @@ -929,14 +933,14 @@ tcl::namespace::eval punk::winlnk { set target_type [dict get $target_type_info type] set target_type_mech [dict get $target_type_info mechanism] if {$target_type eq "unknown"} { - if {[file exists $link_target]} { - set target_type [file type $link_target] + if {[file exists $link_roottarget]} { + set target_type [file type $link_roottarget] set target_type_mech "filesystem" } } set result [dict create\ - link_target $link_target\ + link_roottarget $link_roottarget\ link_flags $flags_enabled\ file_attributes $file_attributes\ creation_time [Header_Get_CreationTime $contents]\ @@ -1017,7 +1021,7 @@ tcl::namespace::eval punk::winlnk { package require punk::lib #punk::lib::showdict [resolve $path] */@* set field_queries [dict create\ - link_target link_target\ + link_roottarget link_roottarget\ link_flags link_flags/@*\ file_attributes file_attributes\ creation_time creation_time\ @@ -1055,32 +1059,33 @@ tcl::namespace::eval punk::winlnk { @id -id ::punk::winlnk::target @cmd -name punk::winlnk::target\ -summary\ - "Return the target path of a .lnk file (windows shortcut)"\ + "Return the target path/commandline of a .lnk file (windows shortcut)"\ -help\ - "Return the target path of the .lnk file specified in path. + "Return the target path/commandline of the .lnk file specified in path. This is a convenience function that extracts the target path from the .lnk file and returns it directly, without all the additional information that resolve provides. If the .lnk header check fails, then - the .lnk file probably isn't really a shortcut file and an error message will be returned. - - Incomplete! - needs to process arguments when HasArguments link flag is set and append the arguments to the target path. - - e.g for a shortcut to 'START /D ...' the target will currently just return a path to cmd.exe - which is insufficient." + the .lnk file probably isn't really a shortcut file and an error message will be returned." @values -min 1 -max 1 path -type string -help "Path to the .lnk file to resolve" }] } + #consider a shortcut to the following: # START /D ^"C:\tcl\bin^" wish.exe c:\cmdfiles\ftp.tcl" - # the target currently only returns c:/Windows/System32/cmd.exe. + # the link_roottarget is c:/Windows/System32/cmd.exe. + proc target {path} { - #*** !doctools - #[call [fun target] [arg path] ] - #[para]Return the target path of the .lnk file specified in path set info [resolve $path] if {[dict exists $info error]} { error [dict get $info error] } else { - return [dict get $info link_target] + set roottarget [dict get $info link_roottarget] + if {[dict exists $info stringdata command_line_arguments]} { + set arguments [dict get $info stringdata command_line_arguments] + return "$roottarget $arguments" + } else { + return $roottarget + } } } @@ -1094,7 +1099,9 @@ tcl::namespace::eval punk::winlnk { } proc Get_target_type {content file_attributes} { - #determine type based on info in the .lnk file, such as file attributes and link flags + #determine target file/directory/link type based on info in the .lnk file, such as file attributes and link flags + #review - a .lnk may target an executable with arguments. + #In this case, the target type may be considered a file (the executable) but it may also be useful to indicate that it's a link to an executable with arguments(?). if {"DIRECTORY" in $file_attributes} { return [dict create type directory mechanism file_attributes]" @@ -1104,31 +1111,31 @@ tcl::namespace::eval punk::winlnk { set iteminfo [Get_LinkTargetIDList_iteminfo $content] if {[llength $iteminfo] > 0} { set first_item [lindex $iteminfo 0] - set first_item_type [dict get $first_item type] + set first_item_type [dict get $first_item typehex] set saw_2f 0 switch -- $first_item_type { "1F" { #plain files and folders always seem to have a first item type of 1F #so does "local disk" - set type_so_far "unknown" - #For a file, we may first see multiple items of type 32 (directory) as we go through the folder structure, - #and then finally an item of type 31 (file) at the end. + set target_type_so_far "unknown" + #For a file, we may first see multiple items of typehex 32 (directory) as we go through the folder structure, + #and then finally an item of typehex 31 (file) at the end. #For a network location, we may see an item of type 2F. #So we need to loop through all the items and keep track of what we've seen so far. foreach item $iteminfo { - set item_type [dict get $item type] - if {$item_type eq "31"} { - set type_so_far "directory" - } elseif {$item_type eq "32"} { + set item_type_hex [dict get $item typehex] + if {$item_type_hex eq "31"} { + set target_type_so_far "directory" + } elseif {$item_type_hex eq "32"} { return [dict create type file mechanism idlist] - } elseif {$item_type eq "2F"} { + } elseif {$item_type_hex eq "2F"} { set saw_2f 1 } } - if {$type_so_far eq "unknown" && $saw_2f} { + if {$target_type_so_far eq "unknown" && $saw_2f} { return [dict create type "local disk" mechanism idlist] } - return [dict create type $type_so_far mechanism idlist] + return [dict create type $target_type_so_far mechanism idlist] } } return [dict create type "unknown" mechanism idlist] diff --git a/src/vfs/_vfscommon.vfs/modules/commandstack-0.4.tm b/src/vfs/_vfscommon.vfs/modules/commandstack-0.4.tm index 19c21289..165bd16a 100644 --- a/src/vfs/_vfscommon.vfs/modules/commandstack-0.4.tm +++ b/src/vfs/_vfscommon.vfs/modules/commandstack-0.4.tm @@ -167,6 +167,12 @@ namespace eval commandstack { lassign $arglist command procargs procbody set command [uplevel 1 [list namespace which $command]] + if {$command eq ""} { + #review + puts stderr "commandstack::rename_command no rename performed for command '$command' by '$renamer'. command '$command' not found in calling context. Ensure command name is fully qualified or that command exists." + #add something to stack? + return [dict create implementation ""] + } set mungedcommand [string map {:: _ns_} $command] set mungedrenamer [string map {:: _ns_} $renamer] variable all_stacks @@ -284,7 +290,8 @@ namespace eval commandstack { ] if {![dict get $nextinfo do_rename]} { #review - puts stderr "no rename performed" + puts stderr "commandstack::rename_command no rename performed for command '$command' by '$renamer'" + #add something to stack? return [dict create implementation ""] } catch {rename ::commandstack::temp::testproc ""} diff --git a/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm index 5a7824f0..ebfb673f 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm @@ -35,29 +35,13 @@ namespace eval punk { " } - proc rehash {{refresh 0}} { - global auto_execs - if {!$refresh} { - unset -nocomplain auto_execs - } else { - set names [array names auto_execs] - unset -nocomplain auto_execs - foreach nm $names { - auto_execok_windows $nm - } - } - return - } proc ::punk::auto_execok_original name [info body ::auto_execok] variable better_autoexec - #set better_autoexec 0 ;#use this var via better_autoexec only - #proc ::punk::auto_execok_windows name { - # ::punk::auto_execok_original $name - #} + #use this var via better_autoexec only set better_autoexec 1 proc ::punk::auto_execok_windows name { ::punk::auto_execok_better $name @@ -166,14 +150,14 @@ namespace eval punk { proc ::punk::auto_execok_windows name { ::punk::auto_execok_better $name } - punk::rehash + punk::auto_exec::rehash } elseif {!$onoff && ($onoff != $better_autoexec)} { puts "Turning off better_autoexec - search extension then PATH" set better_autoexec 0 proc ::punk::auto_execok_windows name { ::punk::auto_execok_original $name } - punk::rehash + punk::auto_exec::rehash } else { puts "no change" } @@ -182,6 +166,16 @@ namespace eval punk { proc auto_execok_better name { + #review - we have a gneral problem of auto_exec caching negative results for relative paths. + #A failed resolution of a relative path should not generate an entry in ::auto_execs. + #This happens in plain tclsh - so we need to determine where in Tcl this happens and fix it there. + #Simply returning an empty string here will still result in a negative cache entry. + #we want to cache negative results for absolute paths or plain filenames with no file-separator. + #e.g ./doesntexist.exe should not be cached as not found, but should be re-resolved every time. (cwd dependent) + #e.g doesntexist.exe should be cached as not found, because it will always be not found until it appears in the PATH. + #i.e it is required to prefix with ./ to exec a file in the current directory. (similar to unix shells) + + global auto_execs env tcl_platform #for now at least, auto_execok_better is windows-specific. package require punk::auto_exec @@ -213,7 +207,16 @@ namespace eval punk { } if {[llength [file split $name]] != 1} { + #----------------------------------------------------- #has a path component - could be relative or absolute. + #----------------------------------------------------- + if {[file pathtype $name] eq "relative"} { + #don't cache negative result for any relative paths - as they may become valid if the file appears in the relative location, or if the user changes directory and the same relative path points to a different file. + #our only way to do this is by cooperating with the unknown handler. + set auto_execs($name) "for_unknown_handler by punk::auto_exec relative_path - file existence should be re-checked at call time" + return $auto_execs($name) + } + if {[string tolower [file extension $name]] eq ".lnk"} { #special case .lnk #todo - consider working directory or other properties of link before launching? @@ -246,11 +249,11 @@ namespace eval punk { set associnfo [punk::auto_exec::shell_open_command $test_ext] set valuetype [dict get $associnfo type] set assoc [dict get $associnfo value] - set ftype [dict get $associnfo filetype] + set windows_file_type [dict get $associnfo filetype] if {$assoc eq ""} { return [set auto_execs($name) [list $file]] } else { - if {[file pathtype $target] eq "relative" && $ftype eq "InternetShortcut"} { + if {[file pathtype $target] eq "relative" && $windows_file_type eq "InternetShortcut"} { #special case InternetShortcut - cannot accept relative path - so we can't cache it in auto_execs if we used a relative path to launch #if we return an empty string - the auto_exec will fail to launch this every time. #The best we can do is return a token for the 'unknown' process to detect and re-resolve the path every time. @@ -260,7 +263,7 @@ namespace eval punk { #e.g ::auto_execs(./link.url) = some.exe c:/desktop/link.url #this would be wrong if the user changed directory and tried to run ./link.url again on a different file with the same name # - as the cached path would no longer be correct. - return [set auto_execs($name) "(resolve_in_unknown_handler) punk::auto_exec absolute_path required"] + return [set auto_execs($name) "for_unknown_handler by punk::auto_exec absolute_path required"] } puts stderr "auto_execok_better: (review required) assoc $assoc for file $file ext $test_ext" set run [punk::auto_exec::shell_command_as_tcl_list -type $valuetype $assoc $file] ;# -workingdir [pwd] vs path of script? @@ -269,6 +272,8 @@ namespace eval punk { } } } + #cache negative result for absolute paths - as they will always point to the same location, so if they don't exist now, they won't exist later. + set auto_execs($name) "" return "" } @@ -559,7 +564,7 @@ if {![llength [info commands ::ansistring]]} { package require punk::repl::codethread package require punk::config #package require textblock -package require punk::console ;#requires Thread +catch {package require punk::console} ;#requires Thread - will not work in safe interps. package require punk::ns package require punk::winpath ;# for windows paths - but has functions that can be called on unix systems package require punk::repo @@ -5396,27 +5401,54 @@ namespace eval punk { } else { set repl_runid [punk::get_repl_runid] #set ::punk::last_run_display [list] - if {$new eq "(resolve_in_unknown_handler) punk::auto_exec absolute_path required"} { - #re-resolve. - puts "(unknown-handler): auto_execok for $name requires absolute path. Re-resolving $name with absolute path." + set resolved $new + if {[string match "for_unknown_handler *" $new]} { set ext [file extension $name] - set associnfo [punk::auto_exec::shell_open_command $ext] - set valuetype [dict get $associnfo type] - set assoc [dict get $associnfo value] - set ftype [dict get $associnfo filetype] - set fullpath [file normalize $name] - #at least for .url files - long paths (paths with multiple spaces?) can fail to run. Using the short path seems to fix this. - #This seems hacky but anyway.. - set attributes [file attributes $fullpath] - if {[dict exists $attributes -shortname]} { - set fullpath [dict get $attributes -shortname] + if {[string tolower $ext] eq ".lnk"} { + #for .lnk files we can often resolve the target path without needing to execute the shell open command + #- which is desirable because it allows us to avoid the absolute path requirement for unknown-handler auto_execok commands, + #which is desirable because it allows us to support relative paths and paths with environment variables in them + #(e.g for .lnk files that point to executables with environment variables in the path) + set targetinfo [punk::winlnk::resolve $name] + if {[dict exists $targetinfo link_roottarget]} { + set resolved [dict get $targetinfo link_roottarget] + #arguments? + } else { + puts "(unknown-handler): failed to resolve .lnk target for $name. Falling back to shell open command resolution, which may fail if absolute path is required." + } + } else { + #re-resolve. + set associnfo [punk::auto_exec::shell_open_command $ext] + set registry_valuetype [dict get $associnfo type] ;#sz vs expand_sz + set command_spec [dict get $associnfo value] + set windows_file_type [dict get $associnfo filetype] + if {[string match "*absolute_path required" $new]} { + puts "(unknown-handler): auto_execok for $name requires absolute path. Re-resolving $name with absolute path." + set fullpath [file normalize $name] + #at least for .url files - long paths (paths with multiple spaces?) can fail to run. Using the short path seems to fix this. + #This seems hacky but anyway.. + set attributes [file attributes $fullpath] + if {[dict exists $attributes -shortname]} { + set fullpath [dict get $attributes -shortname] + } + set resolved [punk::auto_exec::shell_command_as_tcl_list -type $registry_valuetype $command_spec $fullpath] + } else { + #todo + set newnorm [file normalize $name] + puts stderr "(unknown-handler): re-resolving $name with auto_execok $newnorm" + set resolved [auto_execok $newnorm] + } } - set new [punk::auto_exec::shell_command_as_tcl_list -type $valuetype $assoc $fullpath] } - + if {$resolved eq ""} { + #resolved may be emptyif auto_execok returns an empty string. + dict set ::tcl::UnknownOptions -code error + set ::tcl::UnknownResult "unresolved path '$name'" + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } set redir ">&@stdout <@stdin" - uplevel 1 [list ::catch [concat exec $redir $new [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions] + uplevel 1 [list ::catch [concat exec $redir $resolved [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions] #we can't detect stdout/stderr output from the exec #for now emit an extra \n on stderr #todo - there is probably no way around this but to somehow exec in the context of a completely separate console @@ -5502,8 +5534,7 @@ namespace eval punk { set default_cmd_search 0 if {$default_cmd_search} { if {[llength $cmds] == 1} { - uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] \ - ::tcl::UnknownResult ::tcl::UnknownOptions] + uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] ::tcl::UnknownResult ::tcl::UnknownOptions] dict incr ::tcl::UnknownOptions -level return -options $::tcl::UnknownOptions $::tcl::UnknownResult } @@ -6779,46 +6810,6 @@ namespace eval punk { - #tilde - #These aliases work fine for interactive use - but the result is always a string int-rep - #interp alias {} ~ {} file join $::env(HOME) ;#HOME must be capitalized to work cross platform (lowercase home works on windows - but probably not elsewhere) - #interp alias {} ~ {} apply {args {file join $::env(HOME) $args}} - namespace eval argdoc { - punk::args::define { - @id -id ::punk::~ - @cmd -name "punk::~"\ - -summary\ - "Return home directory"\ - -help\ - "Return the home directory path. With additional arguments, - return the path obtained by joining the home directory with - the supplied arguments. - - usage e.g - cd [~] - (change to home directory) - .// [~] .config - (change to .config directory within home directory - and list contents.) - " - @opts - @values -min 0 -max -1 - arg -type any -optional 1 -multiple 1 - } - } - proc ~ {args} { - set hdir [punk::valcopy $::env(HOME)] - file pathtype $hdir - set d $hdir - #use the file join 2-arg optimisation to avoid losing path-rep - probably doesn't give any advantage on all Tcl versions - #review - for what versions does/did the 2-arg version of file join not just return a string? - foreach a $args { - set d [file join $d $a] - } - file pathtype $d - return [punk::valcopy $d] - } - interp alias {} ~ {} punk::~ #maint - punk::args has similar @@ -7735,12 +7726,20 @@ namespace eval punk { -limit -type int -default 20 -help\ "When multiple values are passed to inspect - limit the number of elements displayed in -channel output. + When truncation has occured an elipsis indication (...) will be appended. e.g - .= lseq 20 to 50 by 3 |> .=>* inspect -limit 4 -- |> .=>* tcl::mathop::+ - (11) 20 23 26 29... + ${[punk::args::helpers::example { - - 385 + .= lseq 20 to 50 by 3 |> .=>* inspect -limit 4 -- |> .=>* tcl::mathop::+ + (11) 20 23 26 29... + + - 385 + + }]} + + If the current pipeline data is not a list, the limit is applied to the + number of lines in the pipeline value. For no limit - use -limit -1 " @@ -7881,11 +7880,11 @@ namespace eval punk { } if {$showcount} { set displaycount "[a purple bold]($count)[a] " - if {$showcount} { - set countspace [expr {[string length $count] + 3}] ;#lhs margin size of count number plus brackets and one space - set margin [string repeat " " $countspace] - set displayval [string map [list \r "" \n "\n$margin"] $displayval] - } + #if {$showcount} { + # set countspace [expr {[string length $count] + 3}] ;#lhs margin size of count number plus brackets and one space + # set margin [string repeat " " $countspace] + # set displayval [string map [list \r "" \n "\n$margin"] $displayval] + #} } else { set displaycount "" } @@ -7934,10 +7933,13 @@ namespace eval punk { } if {![string length $more]} { - puts $channel "$displaycount$label$displayval[a]" + #puts $channel "$displaycount$label$displayval[a]" + set chunk [textblock::join -- $displaycount$label " " $displayval[a]] } else { - puts $channel "$displaycount$label$displayval[a yellow bold]$more[a]" + #puts $channel "$displaycount$label$displayval[a yellow bold]$more[a]" + set chunk [textblock::join -- $displaycount$label " " "$displayval[a yellow bold]$more[a]"] } + puts $channel $chunk return $val } @@ -8024,7 +8026,7 @@ namespace eval punk { lappend cmdinfo [list ./ "?${I}glob${NI}?" "view/change dir, list dirs."] lappend cmdinfo [list ../ "?${I}path${NI}" "go up one dir, then to path if given"] lappend cmdinfo [list .// "?${I}glob${NI}?" "view/change dir, list dirs and files"] - lappend cmdinfo [list ./new "${I}subdir${NI}..." "make new dir or dirs and show status"] + lappend cmdinfo [list newdir "${I}subdir${NI}..." "make new dir or dirs and show status"] lappend cmdinfo [list fcat "${I}file ?file?...${NI}" "cat file(s)"] set t [textblock::class::table new -minwidth 80 -show_seps 0] foreach row $cmdinfo { @@ -8046,9 +8048,9 @@ namespace eval punk { set title "[a+ brightgreen] Namespace navigation: " set cmdinfo [list] lappend cmdinfo [list n/ "?${I}ns${NI}|${I}glob${NI}?" "view/change namespace\n (accepts ns path globs e.g **::*get* to match\n commands at any level )"] - lappend cmdinfo [list n// "?${I}ns${NI}|${I}glob${NI}?" "view/change namespace (with command listing)"] - lappend cmdinfo [list "nn/" "" "go up one namespace"] - lappend cmdinfo [list "n/new" "${I}ns${NI}" "make child namespace and switch to it"] + lappend cmdinfo [list n// "?${I}ns${NI}|${I}glob${NI}?" "view/change namespace (with command listing)"] + lappend cmdinfo [list "nn/" "" "go up one namespace"] + lappend cmdinfo [list "newns" "${I}ns${NI}" "make child namespace and switch to it"] set t [textblock::class::table new -minwidth 80 -show_seps 0] foreach row $cmdinfo { $t add_row $row @@ -8236,104 +8238,110 @@ namespace eval punk { lappend chunks [list stdout $text] } console - term - terminal { - set indent [string repeat " " [string length "WARNING: "]] - lappend cstring_tests [dict create\ - type "PM "\ - msg "UN"\ - f7 punk::ansi::controlstring_PM\ - f7prefix "7bit ESC ^ secret "\ - f7suffix "safe"\ - f8 punk::ansi::controlstring_PM8\ - f8prefix "8bit \\x9e secret "\ - f8suffix "safe"\ - ] - lappend cstring_tests [dict create\ - type SOS\ - msg "NOT"\ - f7 punk::ansi::controlstring_SOS\ - f7prefix "7bit ESC X string "\ - f7suffix " hidden"\ - f8 punk::ansi::controlstring_SOS8\ - f8prefix "8bit \\x98 string "\ - f8suffix " hidden"\ - ] - lappend cstring_tests [dict create\ - type APC\ - msg "NOT"\ - f7 punk::ansi::controlstring_APC\ - f7prefix "7bit ESC _ APPLICATION PROGRAM COMMAND "\ - f7suffix " hidden"\ - f8 punk::ansi::controlstring_APC8\ - f8prefix "8bit \\x9f APPLICATION PROGRAM COMMAND "\ - f8suffix " hidden"\ - ] + if {[catch {package require punk::console} result]} { + set text "Unable to load punk::console package - cannot test\n$result" + lappend chunks [list stdout $text] + } else { - foreach test $cstring_tests { - set m [[dict get $test f7] [dict get $test msg]] - set hidden_width_m [punk::console::test_char_width $m] - set m8 [[dict get $test f8] [dict get $test msg]] - set hidden_width_m8 [punk::console::test_char_width $m8] - if {$hidden_width_m != 0 || $hidden_width_m8 != 0} { - if {$hidden_width_m == 0} { - set d "[a+ green bold][dict get $test f7prefix][a red]${m}[a][a+ green bold][dict get $test f7suffix][a]" - } else { - set d "[a+ yellow bold][dict get $test f7prefix][a red]$m[a][a+ yellow bold][dict get $test f7suffix][a]" - } - if {$hidden_width_m8 == 0} { - set d8 "[a+ green ][dict get $test f8prefix][a red]$m8[a][a+ green][dict get $test f8suffix][a]" - } else { - set d8 "[a+ yellow bold][dict get $test f8prefix][a red]$m8[a][a+ yellow bold][dict get $test f8suffix][a]" + set indent [string repeat " " [string length "WARNING: "]] + lappend cstring_tests [dict create\ + type "PM "\ + msg "UN"\ + f7 punk::ansi::controlstring_PM\ + f7prefix "7bit ESC ^ secret "\ + f7suffix "safe"\ + f8 punk::ansi::controlstring_PM8\ + f8prefix "8bit \\x9e secret "\ + f8suffix "safe"\ + ] + lappend cstring_tests [dict create\ + type SOS\ + msg "NOT"\ + f7 punk::ansi::controlstring_SOS\ + f7prefix "7bit ESC X string "\ + f7suffix " hidden"\ + f8 punk::ansi::controlstring_SOS8\ + f8prefix "8bit \\x98 string "\ + f8suffix " hidden"\ + ] + lappend cstring_tests [dict create\ + type APC\ + msg "NOT"\ + f7 punk::ansi::controlstring_APC\ + f7prefix "7bit ESC _ APPLICATION PROGRAM COMMAND "\ + f7suffix " hidden"\ + f8 punk::ansi::controlstring_APC8\ + f8prefix "8bit \\x9f APPLICATION PROGRAM COMMAND "\ + f8suffix " hidden"\ + ] + + foreach test $cstring_tests { + set m [[dict get $test f7] [dict get $test msg]] + set hidden_width_m [punk::console::test_char_width $m] + set m8 [[dict get $test f8] [dict get $test msg]] + set hidden_width_m8 [punk::console::test_char_width $m8] + if {$hidden_width_m != 0 || $hidden_width_m8 != 0} { + if {$hidden_width_m == 0} { + set d "[a+ green bold][dict get $test f7prefix][a red]${m}[a][a+ green bold][dict get $test f7suffix][a]" + } else { + set d "[a+ yellow bold][dict get $test f7prefix][a red]$m[a][a+ yellow bold][dict get $test f7suffix][a]" + } + if {$hidden_width_m8 == 0} { + set d8 "[a+ green ][dict get $test f8prefix][a red]$m8[a][a+ green][dict get $test f8suffix][a]" + } else { + set d8 "[a+ yellow bold][dict get $test f8prefix][a red]$m8[a][a+ yellow bold][dict get $test f8suffix][a]" + } + append warningblock \n "WARNING: terminal doesn't hide all [dict get $test type] control strings: $d $d8" } - append warningblock \n "WARNING: terminal doesn't hide all [dict get $test type] control strings: $d $d8" } - } - if {![catch {punk::console::check::has_bug_legacysymbolwidth} result]} { - if {$result} { - append warningblock \n "WARNING: terminal has legacysymbolwidth bug - screen position for symbol reports 2 wide but displays 1 wide." - append warningblock \n $indent "Layout using 'legacy symbols for computing' affected." - append warningblock \n $indent "(e.g textblock frametype block2 unsupported)" - append warningblock \n $indent "This can cause extreme layout deformation when ANSI is present" - append warningblock \n $indent "In some cases unwanted spacing effects occur at a distance from the characters causing it" + if {![catch {punk::console::check::has_bug_legacysymbolwidth} result]} { + if {$result} { + append warningblock \n "WARNING: terminal has legacysymbolwidth bug - screen position for symbol reports 2 wide but displays 1 wide." + append warningblock \n $indent "Layout using 'legacy symbols for computing' affected." + append warningblock \n $indent "(e.g textblock frametype block2 unsupported)" + append warningblock \n $indent "This can cause extreme layout deformation when ANSI is present" + append warningblock \n $indent "In some cases unwanted spacing effects occur at a distance from the characters causing it" + } + } else { + append warningblock \n "WARNING: terminal unable to check for legacysymbolwidth bug. err:$result" } - } else { - append warningblock \n "WARNING: terminal unable to check for legacysymbolwidth bug. err:$result" - } - if {![catch {punk::console::check::has_bug_zwsp} result]} { - if {$result} { - append warningblock \n "WARNING: terminal has zero width space (\\u200b) bug - cursor position incremented when it shouldn't be." - append warningblock \n $indent "The zwsp may or may not be displayed. zwsp contributes to line length and wrapping point" + if {![catch {punk::console::check::has_bug_zwsp} result]} { + if {$result} { + append warningblock \n "WARNING: terminal has zero width space (\\u200b) bug - cursor position incremented when it shouldn't be." + append warningblock \n $indent "The zwsp may or may not be displayed. zwsp contributes to line length and wrapping point" + } + } else { + append warningblock \n "WARNING: terminal unable to check for zwsp bug. err:$result" } - } else { - append warningblock \n "WARNING: terminal unable to check for zwsp bug. err:$result" - } - set grapheme_support [punk::console::grapheme_cluster_support] - #mode, 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) - if {![dict size $grapheme_support] || [dict get $grapheme_support mode] eq "unsupported" } { - append warningblock \n "WARNING: terminal either doesn't support grapheme clusters, or doesn't report so via decmode 2027 query." - if {[dict size $grapheme_support] && [dict get $grapheme_support available]} { - append warningblock \n $indent "(but punk::console::grapheme_cluster_support has determined it is probably available)" - } - } else { - if {![dict get $grapheme_support available]} { - switch -- [dict get $grapheme_support mode] { - "unset" { - append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is off." - } - "permanently_unset" { - append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is permanently off." - } - "BAD_RESPONSE" { - append warningblock \n "WARNING: terminal doesn't seem to recognize decmode 2027 query. No grapheme cluster support." + set grapheme_support [punk::console::grapheme_cluster_support] + #mode, 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) + if {![dict size $grapheme_support] || [dict get $grapheme_support mode] eq "unsupported" } { + append warningblock \n "WARNING: terminal either doesn't support grapheme clusters, or doesn't report so via decmode 2027 query." + if {[dict size $grapheme_support] && [dict get $grapheme_support available]} { + append warningblock \n $indent "(but punk::console::grapheme_cluster_support has determined it is probably available)" + } + } else { + if {![dict get $grapheme_support available]} { + switch -- [dict get $grapheme_support mode] { + "unset" { + append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is off." + } + "permanently_unset" { + append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is permanently off." + } + "BAD_RESPONSE" { + append warningblock \n "WARNING: terminal doesn't seem to recognize decmode 2027 query. No grapheme cluster support." + } } } } - } - if {![string length $warningblock]} { - set text "No terminal warnings\n" - lappend chunks [list stdout $text] + if {![string length $warningblock]} { + set text "No terminal warnings\n" + lappend chunks [list stdout $text] + } } } topics - help { diff --git a/src/vfs/_vfscommon.vfs/modules/punk/aliascore-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/aliascore-0.1.0.tm index fb5adce3..8450b2c8 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/aliascore-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/aliascore-0.1.0.tm @@ -108,7 +108,7 @@ tcl::namespace::eval punk::aliascore { # the aliascore::init will temporarily extend the exports list to do the import, and then reset the exports to how they were. set aliases [tcl::dict::create\ val ::punk::pipe::val\ - tstr ::punk::lib::tstr\ + tstr ::punk::args::lib::tstr\ list_as_lines ::punk::lib::list_as_lines\ lines_as_list ::punk::lib::lines_as_list\ linelist ::punk::lib::linelist\ @@ -116,7 +116,7 @@ tcl::namespace::eval punk::aliascore { pdict ::punk::lib::pdict\ plist {::punk::lib::pdict -roottype list}\ showlist {::punk::lib::showdict -roottype list}\ - rehash ::punk::rehash\ + rehash ::punk::auto_exec::rehash\ showdict ::punk::lib::showdict\ ansistrip ::punk::ansi::ansistrip\ stripansi ::punk::ansi::ansistrip\ @@ -228,7 +228,7 @@ tcl::namespace::eval punk::aliascore { } } if {!$opt_force && [llength $conflicts]} { - error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts" + error "punk::aliascore::init declined to create any aliases or imports because conflicts found. Use -force == 1 conflicts:\n [join $conflicts "\n "]" } set failed [list] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm index 5abc839d..cb6f796b 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm @@ -273,21 +273,68 @@ tcl::namespace::eval ::punk::args {} tcl::namespace::eval ::punk::args::helpers { variable PUNKARGS namespace export * - #proc B {} {return \x1b\[1m} ;#a+ bold - #proc N {} {return \x1b\[22m} ;#a+ normal - #proc I {} {return \x1b\[3m} ;#a+ italic - #proc NI {} {return \x1b\[23m} ;#a+ noitalic - proc I {} {punk::ansi::a+ italic} - proc B {} {punk::ansi::a+ bold} - proc N {} {punk::ansi::a+ normal} - proc NI {} {punk::ansi::a+ italic} + proc B {} {return \x1b\[1m} ;#a+ bold + proc N {} {return \x1b\[22m} ;#a+ normal + proc I {} {return \x1b\[3m} ;#a+ italic + proc NI {} {return \x1b\[23m} ;#a+ noitalic + #proc I {} {punk::ansi::a+ italic} + #proc B {} {punk::ansi::a+ bold} + #proc N {} {punk::ansi::a+ normal} + #proc NI {} {punk::ansi::a+ italic} lappend PUNKARGS [list { @id -id ::punk::args::helpers::example @cmd -name punk::args::helpers::example\ -summary\ {Display formatting for argdoc example text}\ -help\ - {Wrap } + {Wrap a block of text (e.g tcl code) in a box with optional syntax highlighting and title. + The text is processed with punk::lib::tstr to allow for command substitution and basic formatting, + but without any further dedenting (i.e it's assumed the text is already dedented appropriately + based on context). + The example function is intended for use in punk::args::define scripts to format example text in + the generated documentation, but it can be used in other contexts too. + + The box is a plain grey background with a lighter grey top and bottom border. + There are no side borders so the text can be copied without extra characters getting in the way, + These top and bottom bars are implemented using unicode block characters so the bars are still + visible when ANSI is stripped. + + ${[punk::args::helpers::example -title "[a+ term-yellow Term-blue] Example 1 [a]" { + #A sample of an example block of text with a garish title and some basic tcl syntax highlighting. + + proc test {args} { + puts "[a+ red]hello world[a]" + } + + }]} + + This was generated with code like the following in the punk::args::define script: + + ${[punk::args::helpers::example -syntax none -tstr 1 { + + ${[example -title "[a+ term-yellow Term-blue] Example 1 [a]" { + #A sample of an example block of text with a garish title and some basic tcl syntax highlighting. + + proc test {args} { + puts "[a+ red]hello world[a]" + } + + }]} + + }]} + + Here we eat our own dog food by nesting the example text within an ${[B]}example${[N]} call with -tstr 0 + to prevent the tstr processing of the text, and -syntax none to prevent the syntax highlighting. + This allows us to show the actual code used to generate ${[a+ term-yellow Term-blue]} Example 1 ${[a+ defaultbg][a]} above without having to use any + escaping backslashes etc that may show in the output. + + Note the slight indent of 2 characters on the left of the text in the example block. + This is intentional to show that the text is indented within the box, and as it's reasonably appealing + visually, explains why the -padright option defaults to padding with 2 chars on the right of the text. + + see also ${[B]}punk::args::lib::tstr${[N]} + + } @opts -padright -type integer -default 2 -help\ {Number of padding spaces to add on RHS of text block} @@ -295,9 +342,24 @@ tcl::namespace::eval ::punk::args::helpers { tcl\ " Very basic tcl syntax highlighting of braces,square brackets and comments." - -title -type string -default "" + } + -title -type string -default "" -help\ + {Optional title to display in the top border of the box. + The title is overlaid on the top bar which consists of lower-half block characters. + These block characters are set with foreground black and background silver, so the lower portion + of the bar appears silver. When the title is overlaid on top of this it gets the same colouring + so that the result is black text on siver background, but full height for the width of the title text. + + The title colour can be set to something other than the default black on silver by including ANSI in + the title text, but the bar on either side will still be silver. + e.g -title "[a+ term-yellow Term-blue]yellow on blue title[a]" + } + -tstr -type boolean -default 1 -help\ + {By setting this to false, we can disable tstr processing of the text. This means that the text will be + treated as a literal string and any tstr variable or command substitution will not be processed. + This can be useful if you want to include text that contains tstr formatting characters or commands + without them being interpreted.} -titlealign -type string -choices {left centre right} - } text -type string }] proc example {args} { @@ -317,10 +379,11 @@ tcl::namespace::eval ::punk::args::helpers { -syntax tcl\ -title ""\ -titlealign left\ + -tstr 1\ ] dict for {o v} $optlist { switch -- $o { - -padright - -syntax - -title - -titlealign {} + -padright - -syntax - -title - -titlealign - -notstr {} default { punk::args::parse $args withid ::punk::args::helpers::example return @@ -332,6 +395,7 @@ tcl::namespace::eval ::punk::args::helpers { set opt_syntax [dict get $opts -syntax] set opt_title [dict get $opts -title] set opt_titlealign [dict get $opts -titlealign] + set opt_tstr [dict get $opts -tstr] if {[string index $str 0] eq "\n"} { set str [string range $str 1 end] @@ -341,7 +405,10 @@ tcl::namespace::eval ::punk::args::helpers { } #example is intended to run from a source doc that has already been dedented appropriately based on context # - we don't want to further undent, hence -undent 0 - set str [uplevel 1 [list punk::lib::tstr -undent 0 -return string -eval 1 -allowcommands $str]] + if {$opt_tstr} { + #this is the default + set str [uplevel 1 [list punk::lib::tstr -undent 0 -return string -eval 1 -allowcommands $str]] + } #puts stderr ------------------- #puts $str #puts stderr ------------------- @@ -752,6 +819,10 @@ tcl::namespace::eval punk::args { argument name - only applies to final leader OR final value) (for options/flags this allows the opt-val pair or solo flag to appear multiple times - not necessarily contiguously) + -multipleunique (only valid if -multiple is true) + If true, when multiple values are stored against the same argument + name due to -multiple being true, the values must be unique. + If false, the same value can be stored multiple times. -choices {} A list of allowable values for an argument. The -default value doesn't have to be in the list. @@ -809,6 +880,24 @@ tcl::namespace::eval punk::args { If allows more than one choice the value is a list consisting of items in the choices made available through entries in -choices/-choicegroups. + -choicemultipleunique (default 0) + If choicemultiple is set to allow more than one choice, this + option specifies whether the choices must be unique within the + value list. If true, the same choice can't be selected more than + once. If false, the same choice can be selected multiple times. + -choicemultipleuniqueset (default 0) + Only applies if -choicemultiple is true and -multiple is true. + If choicemultiple is set to allow more than one choice, and + -multiple is true, this option specifies whether the sets of + choices must be unique across multiple occurrences of the argument. + If true, the same set of choices can't be selected more than once + across multiple occurrences of the multi-choice argument. + If false, the same set of choices can be selected multiple times + across multiple occurrences of the argument. + Without this option being set true, if -multiple is true and + -multipleunique is true, then the same set of choices in a + different order would be considered unique, which may not be + desirable. -unindentedfields {} for fields with multi-line values, tell the resolver to treat them as unindented. ie do no indent/unindent processing of @@ -902,8 +991,11 @@ tcl::namespace::eval punk::args { -choiceprefix 1\ -choicerestricted 1\ -choicemultiple {1 1}\ + -choicemultipleunique 0\ + -choicemultipleuniqueset 0\ -unindentedfields {}\ -multiple 0\ + -multipleunique 0\ -regexprepass {}\ -validationtransform {}\ -ensembleparameter 0\ @@ -918,8 +1010,11 @@ tcl::namespace::eval punk::args { -choiceprefix 1\ -choicerestricted 1\ -choicemultiple {1 1}\ + -choicemultipleunique 0\ + -choicemultipleuniqueset 0\ -unindentedfields {}\ -multiple 0\ + -multipleunique 0\ -regexprepass {}\ -validationtransform {}\ -prefix 1\ @@ -938,8 +1033,11 @@ tcl::namespace::eval punk::args { -choiceprefix 1\ -choicerestricted 1\ -choicemultiple {1 1}\ + -choicemultipleunique 0\ + -choicemultipleuniqueset 0\ -unindentedfields {}\ -multiple 0\ + -multipleunique 0\ -regexprepass {}\ -validationtransform {}\ ] @@ -1718,7 +1816,8 @@ tcl::namespace::eval punk::args { } -unindentedfields - -minsize - -maxsize - - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - + -choices - -choicegroups - -choicemultiple - + -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted { #review - only apply to certain types? tcl::dict::set tmp_optspec_defaults $k $v @@ -1807,7 +1906,8 @@ tcl::namespace::eval punk::args { -allow_ansi - -validate_ansistripped - -strip_ansi - - -multiple - + -multiple - -multipleunique - + -choicemultipleunique - -choicemultipleuniqueset - -prefix { #check is bool if {![string is boolean -strict $v]} { @@ -1823,6 +1923,7 @@ tcl::namespace::eval punk::args { -unindentedfields\ -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple -prefix\ + -multipleunique -choicemultipleunique -choicemultipleuniqueset\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ } error "punk::args::resolve - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" @@ -1936,7 +2037,10 @@ tcl::namespace::eval punk::args { -allow_ansi - -validate_ansistripped - -strip_ansi - - -multiple { + -multiple - + -multipleunique - + -choicemultipleunique - -choicemultipleuniqueset - + -optional { if {![string is boolean -strict $v]} { error "punk::args::resolve - invalid type of value '$v' for key '$k' in @leaders line. Must be boolean @id:$DEF_definition_id" } @@ -1961,6 +2065,7 @@ tcl::namespace::eval punk::args { -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ -unindentedfields\ -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -multipleunique -choicemultipleunique -choicemultipleuniqueset\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ -unnamed\ } @@ -2051,11 +2156,13 @@ tcl::namespace::eval punk::args { -typeranges { tcl::dict::set tmp_valspec_defaults -typeranges $v } - -optional - -allow_ansi - -validate_ansistripped - -strip_ansi - - -multiple { + -multiple - + -multipleunique - + -choicemultipleunique - -choicemultipleuniqueset - + -optional { if {![string is boolean -strict $v]} { error "punk::args::resolve - invalid type of value '$v' for key '$k' in @values line. Must be boolean @id:$DEF_definition_id" } @@ -2083,6 +2190,7 @@ tcl::namespace::eval punk::args { -unindentedfields\ -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -multipleunique -choicemultipleunique -choicemultipleuniqueset\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ -unnamed\ } @@ -2414,6 +2522,7 @@ tcl::namespace::eval punk::args { -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted - -choicelabels - -choiceinfo - -minsize - -maxsize - -nocase - -multiple - + -multipleunique - -choicemultipleunique - -choicemultipleuniqueset - -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - -regexprepass - -regexprefail - -regexprefailmsg { @@ -2519,6 +2628,7 @@ tcl::namespace::eval punk::args { -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted\ -unindentedfields\ -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -multipleunique -choicemultipleunique -choicemultipleuniqueset\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ -ensembleparameter\ ] @@ -9228,7 +9338,7 @@ tcl::namespace::eval punk::args { set v_test $c_check } set choice_in_list 0 - set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? + set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval could be a list when -choicemultiple? if {!$matches_default} { if {$choiceprefix} { #can we handle empty string as a choice? It should just work - REVIEW/test @@ -9277,6 +9387,7 @@ tcl::namespace::eval punk::args { set chosen $bestmatch set choice_in_list 1 } + puts ">>>>> chosen: $chosen bestmatch: $bestmatch for c_check: $c_check choices_test: $choices_test allchoices: $allchoices" } else { set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check] if {$chosen eq "" || $chosen in $choiceprefixreservelist} { @@ -9302,9 +9413,11 @@ tcl::namespace::eval punk::args { if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { #single choice allowed per clause-member if {$is_multiple} { + puts ">>>>> existing:'$existing' element_index:$element_index choice_index:$choice_idx chosen: $chosen" if {$clause_size == 1} { #no list wrapping of single element in $dname dict - so don't index into it with element_index - lset existing $element_index $chosen + #lset existing $element_index $chosen ;#wrong - test::punk::args test: choice_multiple_with_choiceprefix. + lset existing $clause_index $chosen } else { lset existing $clause_index $element_index $chosen } @@ -10626,10 +10739,29 @@ tcl::namespace::eval punk::args::lib { Placeholder Substitutions: \$\{$varName\} \$\{[myCommand]\} - (when -allowcommands flag is given)" + (myCommand is evaluated when -allowcommands flag is given) + + If any error occurs during placeholder evaluation, the original placeholder text + is substituted in the output and the error is included in the returned dict + (if -return dict is used). + " -allowcommands -default 0 -type none -help\ - "If -allowcommands is present, placeholder can contain commands - e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" + "If -allowcommands is present, placeholder commands are evaluated and subtituted. + e.g tstr -allowcommands { \$\{plaintext0 [lindex $var 1] plaintext2\} } + + if $var is {a b c}, the result will be \"plaintext0 b plaintext2 \" + if $var does not exist the result will be \"\$\{plaintext0 [lindex $var 1] plaintext2\} \" + with an error recorded in the returned dict if -return dict is used. + + NOTE: even if -allowcommands is not present, the placeholder text is still processed for variable + substitution and escape sequence processing, so the result will not be the raw placeholder text. + The result will be \"plaintext0 [lindex {a b c} 0] plaintext2 \" + + e.g + tstr -undent 0 -allowcommands { \$\{ \\$var\\[1\\] = [lindex $var 1]\}} + $var[1] = b + " + -undent -default 1 -type boolean -help\ "undent/dedent the template lines. The longest common prefix of whitespace is removed" @@ -10702,6 +10834,14 @@ tcl::namespace::eval punk::args::lib { which expects the placeholders as individual arguments" } + -raise_errors -default 0 -type boolean -help\ + "By default, if an error occurs during placeholder evaluation, the original placeholder text + is substituted in the output and the error is included in the returned dict (if -return dict is used). + If -raise_errors is set to 1, the template will be processed and a list of errors will be collected as + normal, but if any errors are present at the end of processing, a single error will be raised with a + summary of all errors that occurred. + This can be useful for debugging or when you want to ensure that any issues with placeholder evaluation + are immediately visible and not silently included in the output." -eval -default 1 -type boolean -help\ "Whether to evaluate the \$\{\} placeholders. When -return is string, -eval should generally be set to 1. @@ -10739,6 +10879,7 @@ tcl::namespace::eval punk::args::lib { -paramindents line\ -eval 1\ -return string\ + -raise_errors 0\ ] if {"-allowcommands" in $arglist} { set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] @@ -10754,9 +10895,9 @@ tcl::namespace::eval punk::args::lib { } } dict for {k v} $arglist { - set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] + set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval -raise_errors} $k] switch -- $fullk { - -indent - -undent - -paramindents - -return - -eval { + -indent - -undent - -paramindents - -return - -eval - -raise_errors { dict set opts $fullk $v } default { @@ -10781,6 +10922,7 @@ tcl::namespace::eval punk::args::lib { set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] if {$opt_return eq ""} { } + set opt_raise_errors [dict get $opts -raise_errors] set opt_eval [dict get $opts -eval] @@ -10871,6 +11013,14 @@ tcl::namespace::eval punk::args::lib { incr idx ;#expression incr } + if {$opt_raise_errors && [dict size $errors]} { + set einfo "" + dict for {i e} $errors { + append einfo "parameter $i error: $e" \n + } + error "punk::args::lib::tstr: Errors occurred during placeholder evaluation:\n$einfo" + } + if {$opt_return eq "dict"} { return [dict create template $textchunks params $params errors $errors] } @@ -11200,17 +11350,39 @@ tcl::namespace::eval punk::args::package { set pkgname [${pkgns}::package_name] set opt_return [dict get $OPTS -return] - set all_topics [${pkgns}::about_topics] + set defined_topics [${pkgns}::about_topics] if {![dict exists $received topic]} { - set topics $all_topics + set topics $defined_topics } else { # * represents all remaining topics not explicitly mentioned. set val_topics [dict get $values topic] ;#if -multiple is true, this is a list - set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] + #set explicit_topic_prefixes [lsearch -all -inline -exact -not $val_topics "*"] + set explicit_topics [list] + set requested_topics [list] + set defined_topics_lc [lmap t $defined_topics {string tolower $t}] + foreach et $val_topics { + #topics are case insensitive. We don't expect function names from about_topics to have variations differing only in case. + #todo - enforce this by only returning the last value from about_topics for each particular topic when there are duplicates differing only in case. + #(see punk::auto_execs for example. TODO -add to template or use helper function to enforce this when processing about_topics) + if {$et eq "*"} { + lappend requested_topics "*" + continue + } + + set fulltopic_lc [tcl::prefix::match -error "" $defined_topics_lc [string tolower $et]] + if {$fulltopic_lc eq ""} { + error "punk::args::package::standard_about topic '$et' does not match any defined topics: $defined_topics" + } else { + set resolved_topic [lsearch -inline -nocase $defined_topics $fulltopic_lc] + lappend explicit_topics $resolved_topic + lappend requested_topics $resolved_topic + } + } + set topics [list] - foreach t $val_topics { + foreach t $requested_topics { if {$t eq "*"} { - foreach a $all_topics { + foreach a $defined_topics { if {$a ni $explicit_topics} { lappend topics $a } diff --git a/src/vfs/_vfscommon.vfs/modules/punk/auto_exec-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/auto_exec-0.1.0.tm index 22486038..662656cb 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/auto_exec-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/auto_exec-0.1.0.tm @@ -47,6 +47,45 @@ tcl::namespace::eval punk::auto_exec { set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline] } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id "::punk::auto_exec::rehash" + @cmd -name "punk::auto_exec::rehash"\ + -summary\ + "Update the hash table of autoexec commands cached in ::auto_execs."\ + -help\ + {Clear/refresh the autoexec commands in the ::auto_execs array. + + This is analogous to the 'rehash' command in shells such as csh, tcsh and zsh. + It updates the shell's hash table of executable commands. + + This can be useful after installing new software, adjusting the environment PATH directories, or (on windows) making + changes to the system that may affect file type associations and their associated commands, to ensure that the autoexec + commands are up to date with the current state of the system. + + If refresh is false (the default), then all autoexec commands are cleared and will re-register as commands are called. + If refresh is true, then all existing autoexec commands are re-registered by calling auto_execok for each of them again.} + @opts + @values -min 0 -max 1 + refresh -type boolean -default 0 -help\ + "Whether to re-register existing autoexec commands by calling auto_execok for each of them again." + }] + } + proc rehash {{refresh 0}} { + global auto_execs + if {!$refresh} { + unset -nocomplain auto_execs + } else { + set names [array names auto_execs] + unset -nocomplain auto_execs + foreach nm $names { + #auto_execok_windows $nm + auto_execok $nm + } + } + return + } + variable PUNKARGS lappend PUNKARGS [list { @id -id "::punk::auto_exec::shell_open_command" @@ -347,7 +386,7 @@ tcl::namespace::eval punk::auto_exec { if {!$new_chunk} { if {$current_chunk ne "" || $current_chunk eq "" && [lindex $quoted end]} { - #we add the current chunk to the result list if it's not empty, or if it is empty but is quoted (because in that case we want to preserve it as an empty argument). + #we add the current chunk to the result list if it's not empty, or if it is empty but is quoted (because in that case we want to preserve it as an empty argument). lappend result $current_chunk lappend quoted 0 set current_chunk {} @@ -564,15 +603,17 @@ tcl::namespace::eval punk::auto_exec { user-specific association is found. Returns a dict of dicts with toplevel keys for each shell verb (e.g open, runas) and values that are dicts with keys - ${$I}type${$NI} and ${$I}value${$NI} and ${$I}scope${$NI}, where - type is determined from the registry value type (e.g sz or expand_sz) - string is the raw command string from the registry - scope is either "user" or "system" depending on whether the value was found in the user-specific registry keys or - the system registry keys. + ${$I}type${$NI} and ${$I}value${$NI} and ${$I}scope${$NI}, where: + + ${$I}type${$NI} is determined from the registry value type (e.g sz or expand_sz) + + ${$I}string${$NI} is the raw command string from the registry + + ${$I}scope${$NI} is either \"user\" or \"system\" depending on whether the value was found in the user-specific + registry keys or the system registry keys. This is somewhat like the windows 'ftype' command except that the windows command only looks for the 'open' verb and - only looks up the system association and does not take into account any user-specific - overrides. + only looks up the system association and does not take into account any user-specific overrides. The file type can be looked up using the ${$B}assoc${$N} function in this package. @@ -587,40 +628,11 @@ tcl::namespace::eval punk::auto_exec { This can be looked up using the 'assoc' function in this package." }] } - #proc ftype {filetype} { - # package require registry - - # if {$filetype eq "cplfile"} { - # #special case for cplfile (associated with .cpl files) which doesn't follow the usual pattern of having the command string under shell\open\command, - # #but instead has it under HKEY_LOCAL_MACHINE\SOFTWARE\Classes\cplfile\shell\cplopen\command. - # #There doesn't seem to be any user-specific override for this file type - # #- but we will check for one under HKEY_CURRENT_USER\Software\Classes\cplfile\shell\cplopen\command anyway for consistency with the way we check - # #for user-specific overrides for other file types. - # set key [join [list HKEY_CURRENT_USER Software Classes cplfile shell cplopen command] "\\"] - # } else { - # set key [join [list HKEY_CURRENT_USER Software Classes $filetype shell open command] "\\"] - # } - # if {![catch {registry get $key ""} raw_assoc]} { - # set tp [registry type $key ""] - # return [dict create open [dict create type $tp string $raw_assoc]] - # } else { - # #e.g Python.File - # if {$filetype eq "cplfile"} { - # set key [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes cplfile shell cplopen command] "\\"] - # } else { - # set key [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $filetype shell open command] "\\"] - # } - # if {![catch {registry get $key ""} raw_assoc]} { - # set tp [registry type $key ""] - # return [dict create type $tp string $raw_assoc] - # } else { - # return [dict create type "" string ""] ;#no association found - # } - # } - #} proc ftype {filetype} { package require registry set resultdict [dict create] + #registry queries are case insensitive but some are keys are cased differently e.g Open vs open. + #when using the verb as a key in the output dict, we need to normalize so that it is useful for lookups. We'll use lowercase for that. #e.g Python.File set shellpath [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $filetype shell] "\\"] @@ -628,8 +640,6 @@ tcl::namespace::eval punk::auto_exec { foreach verb $shellverbs { set commandkey [join [list $shellpath $verb command] "\\"] if {![catch {registry get $commandkey ""} cmdstring]} { - #registry queryies are case insensitive but some are cased differently e.g Open vs open. - #when using the verb as a key in the output dict, we need to normalize so that it is useful for lookups. We'll use lowercase for that. set verb [string tolower $verb] set tp [registry type $commandkey ""] dict set resultdict $verb [dict create type $tp value $cmdstring scope system] @@ -649,7 +659,6 @@ tcl::namespace::eval punk::auto_exec { } } } - return $resultdict } @@ -671,9 +680,9 @@ tcl::namespace::eval punk::auto_exec::lib { #} -# == === === === === === === === === === === === === === === +# == === === === === === === === === === === === === === === # Sample 'about' function with punk::args documentation -# == === === === === === === === === === === === === === === +# == === === === === === === === === === === === === === === tcl::namespace::eval punk::auto_exec { tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase variable PUNKARGS @@ -682,8 +691,7 @@ tcl::namespace::eval punk::auto_exec { lappend PUNKARGS [list { @id -id "(package)punk::auto_exec" @package -name "punk::auto_exec" -help\ - "Package - Description" + "An autoexec_ok replacement for Tcl with support for windows file type associations and command string parsing." }] namespace eval argdoc { @@ -695,26 +703,34 @@ tcl::namespace::eval punk::auto_exec { #info commands results are returned in an arbitrary order (like array keys) set topic_funs [info commands [namespace current]::get_topic_*] set about_topics [list] + #use a dict to enforce last case-variation of a topic wins. + set case_dict [dict create] foreach f $topic_funs { set tail [namespace tail $f] - lappend about_topics [string range $tail [string length get_topic_] end] + set t [string range $tail [string length get_topic_] end] + set t_lc [string tolower $tail] + dict set case_dict $t_lc $t + } + dict for {lc t} $case_dict { + lappend about_topics $t } + #Adjust this function or 'default_topics' if a different order is required return [lsort $about_topics] } proc default_topics {} {return [list Description *]} # ------------------------------------------------------------- - # get_topic_ functions add more to auto-include in about topics + # get_topic_ functions add more to auto-include in about topics # ------------------------------------------------------------- proc get_topic_Description {} { - punk::args::lib::tstr [string trim { - package punk::auto_exec - description to come.. + punk::args::lib::tstr [string trim { + package punk::auto_exec + A replacement for Tcl's builtin autoexec_ok function. } \n] } proc get_topic_License {} { - return "" + return "BSD-3-Clause" } proc get_topic_Version {} { return "$::punk::auto_exec::version" @@ -730,22 +746,41 @@ tcl::namespace::eval punk::auto_exec { } return $contributors } - proc get_topic_custom-topic {} { - punk::args::lib::tstr -return string { - A custom - topic - etc - } + proc get_topic_Notes {} { + return [string trim { + This package primarily provides advanced features on the windows platform, but some functions such as 'rehash' are + useful on any platform. + + This package provides functions to look up windows file type associations and to parse command strings with placeholders + and environment variables, which can be used as a replacement for Tcl's autoexec_ok function in certain contexts. + + The 'assoc' function looks up the associated file type for a given file extension, taking into account both user-specific + and system-wide associations in the registry. + + The 'ftype' function looks up the shell verb command values for a given file type, also taking into account both user-specific + and system-wide associations in the registry. + + The 'shell_command_as_tcl_list' function processes a command string with placeholders and environment variables and returns a + Tcl list of command and arguments with the placeholders substituted according to the specified rules. + + } \n] } + #proc get_topic_custom-topic {} { + # punk::args::lib::tstr -return string { + # A custom + # topic + # etc + # } + #} # ------------------------------------------------------------- } # we re-use the argument definition from punk::args::standard_about and override some items set overrides [dict create] dict set overrides @id -id "::punk::auto_exec::about" - dict set overrides @cmd -name "punk::auto_exec::about" + dict set overrides @cmd -name "punk::auto_exec::about" dict set overrides @cmd -help [string trim [punk::args::lib::tstr { - About punk::auto_exec + About punk::auto_exec }] \n] dict set overrides topic -choices [list {*}[punk::auto_exec::argdoc::about_topics] *] dict set overrides topic -choicerestricted 1 @@ -761,7 +796,7 @@ tcl::namespace::eval punk::auto_exec { } } # end of sample 'about' function -# == === === === === === === === === === === === === === === +# == === === === === === === === === === === === === === === # ----------------------------------------------------------------------------- @@ -776,11 +811,11 @@ namespace eval ::punk::args::register { # ----------------------------------------------------------------------------- # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::auto_exec [tcl::namespace::eval punk::auto_exec { variable pkg punk::auto_exec variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/config-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/config-0.1.tm index 8d5a5dca..3d967541 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/config-0.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/config-0.1.tm @@ -15,13 +15,16 @@ tcl::namespace::eval punk::config { namespace eval punk {namespace export config} proc _homedir {} { - if {[info exists ::env(HOME)]} { - set home [file normalize $::env(HOME)] - } else { - #not available on 8.6? ok will error out here. - set home [file tildeexpand ~] - } - return $home + return [punk::nav::fs::~] ;#will work if HOME is not set. + #may return an error if no home directory can be determined + + #if {[info exists ::env(HOME)]} { + # set home [file normalize $::env(HOME)] + #} else { + # #not available on 8.6? ok will error out here. + # set home [file tildeexpand ~] + #} + #return $home } lappend PUNKARGS [list { diff --git a/src/vfs/_vfscommon.vfs/modules/punk/du-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/du-0.1.0.tm index 6d2eb59f..ad27135d 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/du-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/du-0.1.0.tm @@ -1712,7 +1712,7 @@ namespace eval punk::du { set errors [dict create] foreach {k v} $args { switch -- $k { - -glob - -with_sizes - -with_times { + -glob - -filedebug - -patterndebug - -link_info - -with_sizes - -with_times - -types { dict set opts $k $v } default { @@ -1766,6 +1766,7 @@ namespace eval punk::du { set types_entry [list] set types_attribute [list] set types_permission [list] + set types_REQUIRED [list] foreach t $entry_and_attribute_types { switch -- $t { f - d - l - p - s - b - c { @@ -1775,16 +1776,46 @@ namespace eval punk::du { hidden - readonly { #these are all valid attributes lappend types_attribute $t + lappend types_REQUIRED $t } r - w - x { #these are all valid permissions lappend types_permission $t + lappend types_REQUIRED $t } default { error "du_dirlisting_generic unrecognized element in -types '$t'. Known types/attributes/permissions: f d l p s b c hidden readonly r w x" } } } + + set do_sizes_d [expr {"d" in $sized_types}] + set do_sizes_f [expr {"f" in $sized_types}] + set do_sizes_l [expr {"l" in $sized_types}] + set do_times_d [expr {"d" in $timed_types}] + set do_times_f [expr {"f" in $timed_types}] + set do_times_l [expr {"l" in $timed_types}] + if {[llength $types_entry] && "d" ni $types_entry} { + set skip_dirs 1 + } else { + set skip_dirs 0 + } + if {[llength $types_entry] && "f" ni $types_entry} { + set skip_files 1 + } else { + set skip_files 0 + } + if {[llength $types_entry] && "l" ni $types_entry} { + set skip_links 1 + } else { + set skip_links 0 + } + set trequire_hidden [expr {"hidden" in $types_REQUIRED}] + set trequire_readonly [expr {"readonly" in $types_REQUIRED}] + set trequire_executable [expr {"x" in $types_REQUIRED}] + set trequire_readable [expr {"r" in $types_REQUIRED}] + set trequire_writable [expr {"w" in $types_REQUIRED}] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- # The repeated globs are a source of slowness for this function. @@ -1813,56 +1844,42 @@ namespace eval punk::du { if {$opt_glob eq "*"} { #Note - multiple glob operations with restrictions seem to be faster than looped tests like 'file isdirectory' & 'file readlink' #set parent [lindex $folders $folderidx] - if {![llength $types_entry] || "d" in $types_entry} { - #we need to check directories for hidden attribute - as on windows, not all dotfiles are hidden, and not all hidden files are dotfiles - set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} * .*] - set dirs [glob -nocomplain -dir $folderpath -types d * .*] - } - if {![llength $types_entry] || "l" in $types_entry} { - set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} * .*] - set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique - } - if {![llength $types_entry] || "f" in $types_entry} { - set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} * .*] - set files [glob -nocomplain -dir $folderpath -types f * .*] - } + set globs [list *] } else { - if {![llength $types_entry] || "d" in $types_entry} { - #we need to check directories for hidden attribute - as on windows, not all dotfiles are hidden, and not all hidden files are dotfiles - set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} $opt_glob] - set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] - } - if {![llength $types_entry] || "l" in $types_entry} { - set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} $opt_glob] - set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique - } - if {![llength $types_entry] || "f" in $types_entry} { - set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} $opt_glob] - set files [glob -nocomplain -dir $folderpath -types f $opt_glob] - } + set globs [list $opt_glob] + } + #on windows this is a lot of separate globs to perform. Using the du_dirlisting_twapi is preferred for performance on windows - but this is a fallback and for testing. + #if {![llength $types_entry] || "d" in $types_entry} {} + if {!$skip_dirs} { + #we need to check directories for hidden attribute - as on windows, not all dotfiles are hidden, and not all hidden files are dotfiles + set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} {*}$globs] + set dirs [glob -nocomplain -dir $folderpath -types d {*}$globs] + } + if {!$skip_links} { + set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} {*}$globs] + set links [glob -nocomplain -dir $folderpath -types l {*}$globs] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique + } + if {!$skip_files} { + set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} {*}$globs] + set files [glob -nocomplain -dir $folderpath -types f {*}$globs] } } else { if {$opt_glob eq "*"} { - #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink' - #set parent [lindex $folders $folderidx] - #set dirs [glob -nocomplain -dir $folderpath -types d * .*] - #set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique - #set files [glob -nocomplain -dir $folderpath -types f * .*] set globs [list * .*] } else { set globs [list $opt_glob] - #set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] - #set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique - #set files [glob -nocomplain -dir $folderpath -types f $opt_glob] } - - if {![llength $types_entry] || "d" in $types_entry} { + #we need to classify our results - unlike a standard glob * operation which returns all entries in one collection. + #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink' + #however - these are still significantly slower than a single glob with no restrictions - so we want to minimize the number of globs we do + #- but we also want to avoid doing extra work classifying entries that we will end up ignoring based on types/attributes/permissions filters. + if {!$skip_dirs} { set dirs [glob -nocomplain -dir $folderpath -types d {*}$globs] } - if {![llength $types_entry] || "l" in $types_entry} { + if {!$skip_links} { set links [glob -nocomplain -dir $folderpath -types l {*}$globs] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique } - if {![llength $types_entry] || "f" in $types_entry} { + if {!$skip_files} { set files [glob -nocomplain -dir $folderpath -types f {*}$globs] } @@ -1957,6 +1974,7 @@ namespace eval punk::du { set types_entry [list] set types_attribute [list] set types_permission [list] + set types_REQUIRED [list] foreach t $entry_and_attribute_types { switch -- $t { f - d - l - p - s - b - c { @@ -2155,7 +2173,7 @@ namespace eval punk::du { set errors [dict create] if {"windows" eq $::tcl_platform(platform)} { if {$opt_glob eq "*"} { - set globs [list * .*] + set globs [list *] } else { set globs [list $opt_glob] } @@ -2295,6 +2313,13 @@ namespace eval punk::du { #we don't classify anything as 'flaggedhidden' on unix. #it is a convention for dotfiles rather than a flag - and we'll leave the distinction for the display library + set dirs {} + set hdirs {} + set files {} + set hfiles {} + set links {} + set hlinks {} + if {$opt_glob eq "*"} { set globs [list * .*] } else { @@ -2341,6 +2366,7 @@ namespace eval punk::du { if {"$ft" in $meta_types} { foreach path [set $lvar] { if {$has_winpath && [punk::winpath::illegalname_test $path]} { + #review. we don't want to fix the path - we just want classify it as nonportable set testpath [punk::winpath::illegalname_fix $path] if {![catch {file stat $testpath arrstat} errM]} { dict set meta_dict $path [dict create shorttype $ft {*}[array get arrstat]] @@ -2350,7 +2376,7 @@ namespace eval punk::du { dict set meta_dict $path [dict create shorttype $ft {*}$empty_stat_dict] } } else { - #caller may have read perm on the containing folder - but not on child item - so file stat could raise an error + #caller may have permission to read on the containing folder - but not on child item - so file stat could raise an error if {![catch {file stat $path arrstat} errM]} { dict set meta_dict $path [dict create shorttype $ft {*}[array get arrstat]] } else { @@ -2463,28 +2489,38 @@ namespace eval punk::du { } proc du_dirlisting_undecided {folderpath args} { - if {"windows" eq $::tcl_platform(platform)} { - #jmn disable twapi - #tailcall du_dirlisting_generic $folderpath {*}$args - - package require zzzload - set loadstate [zzzload::pkg_require twapi] - if {$loadstate ni [list loading failed]} { - #either already loaded by zzload or ordinary package require - package require twapi ;#should be fast once twapi dll loaded in zzzload thread - set ::punk::du::has_twapi 1 - punk::du::active::set_active_function du_dirlisting du_dirlisting_twapi - tailcall du_dirlisting_twapi $folderpath {*}$args - } else { - if {$loadstate eq "failed"} { - puts stderr "punk::du defaulting to du_dirlisting_generic because twapi load failed" - punk::du::active::set_active_function du_dirlisting du_dirlisting_generic + switch -- $::tcl_platform(platform) { + windows { + #jmn disable twapi + #tailcall du_dirlisting_generic $folderpath {*}$args + + package require zzzload + set loadstate [zzzload::pkg_require twapi] + + if {$loadstate ni [list loading failed]} { + #either already loaded by zzload or ordinary package require + package require twapi ;#should be fast once twapi dll loaded in zzzload thread + set ::punk::du::has_twapi 1 + punk::du::active::set_active_function du_dirlisting du_dirlisting_twapi + tailcall du_dirlisting_twapi $folderpath {*}$args + } else { + if {$loadstate eq "failed"} { + puts stderr "punk::du defaulting to du_dirlisting_generic because twapi load failed" + punk::du::active::set_active_function du_dirlisting du_dirlisting_generic + } + tailcall du_dirlisting_generic $folderpath {*}$args } - tailcall du_dirlisting_generic $folderpath {*}$args } - } else { - punk::du::active::set_active_function du_dirlisting du_dirlisting_unix - tailcall du_dirlisting_unix $folderpath {*}$args + default { + #todo - macOS specific optimizations? e.g using macos metadata to determine hidden/readonly/system flags etc? + #macOS uses a case-insensitive filesystem by default like windows. + + #punk::du::active::set_active_function du_dirlisting du_dirlisting_unix + #tailcall du_dirlisting_unix $folderpath {*}$args + + punk::du::active::set_active_function du_dirlisting du_dirlisting_generic + tailcall du_dirlisting_generic $folderpath {*}$args + } } } diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/util-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/util-0.1.0.tm index e816e1ef..9de4a33d 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/util-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/util-0.1.0.tm @@ -127,9 +127,14 @@ namespace eval punk::mix::util { foreach p $finalpaths { if {$has_winlnk && [file extension $p] eq ".lnk"} { set resolve_info [punk::winlnk::resolve $p] - set resolved [dict get $resolve_info link_target] + set resolved [dict get $resolve_info link_roottarget] if {$resolved ne ""} { - lappend resolved_finalpaths $resolved + if {[dict exists $resolve_info stringdata command_line_arguments]} { + puts stderr "link $p has arguments. Will cat the .lnk file itself rather than the root target." + lappend resolved_finalpaths $p + } else { + lappend resolved_finalpaths $resolved + } } else { lappend resolved_finalpaths $p } diff --git a/src/vfs/_vfscommon.vfs/modules/punk/nav/fs-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/nav/fs-0.1.0.tm index 24dfad86..6d877c5f 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/nav/fs-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/nav/fs-0.1.0.tm @@ -157,6 +157,177 @@ tcl::namespace::eval punk::nav::fs { #[list_begin definitions] + #only lookup user_home once per interp or process + #It can be slightly expensive (for example involving network calls on windows domains) + variable user_home_cache + set user_home_cache "" + + #tilde + #These aliases work fine for interactive use - but the result is always a string internal-rep + #interp alias {} ~ {} file join $::env(HOME) ;#HOME must be capitalized to work cross platform (lowercase home works on windows - but probably not elsewhere) + #interp alias {} ~ {} apply {args {file join $::env(HOME) $args}} + namespace eval argdoc { + punk::args::define { + @id -id ::punk::nav::fs::~ + @cmd -name "punk::nav::fs::~"\ + -summary\ + "Return user's home directory as the process sees it"\ + -help\ + "Return the user's home directory path as the process sees it. + + (This is not always the same as ::env(HOME)) + + With additional arguments, return the path obtained by joining + the user's home directory with the supplied arguments. + + usage e.g + cd [~] + (change to user's home) + .// [~] .config + (change to .config directory within the user's home + and list contents.) + equivalently: + gohome .config + (gohome uses the output of ~ to determine the home directory) + + If the home directory cannot be determined due to the environment + in which the process is running, an error will be raised, as returning + an empty string is not a useful result and can cause issues if used as a path. + " + @opts + @values -min 0 -max -1 + arg -type any -optional 1 -multiple 1 + } + } + proc ~ {args} { + #review - HOME may be undefined or have been set to another value by other tools or the parent process. + #The process may even be running in a context where there is no home directory - e.g a container with no users, or a system service context. + #(we may be in a safe interp - which generally won't have env vars or filesystem access) + variable user_home_cache + if {$user_home_cache ne ""} { + set hdir $user_home_cache + #we still need to process args to join them to the home directory - but we can skip all the work of determining the home directory again. + } else { + set hdir "" + + if {[catch {auto_execok whoami} whoami_exe]} { + set whoami_exe "" + } + if {$whoami_exe eq ""} { + #try env USER or USERNAME - these are commonly set to the username on many platforms - but may not be set in all contexts. + if {[info exists ::env(USER)]} { + set user $::env(USER) + } elseif {[info exists ::env(USERNAME)]} { + set user $::env(USERNAME) + } else { + set user "" + } + } else { + #set user [exec {*}$whoami_exe] + if {[catch {exec {*}$whoami_exe} user]} { + set user "" + } + } + if {[string trim $user] ne ""} { + #normalize user for use with 'file tildeexpand ~' + #on windows, whoami may return DOMAIN\USER + #for tildeexpand to work, we need to convert this to USER@DOMAIN + if {"windows" eq $::tcl_platform(platform)} { + set parts [split $user "\\"] + #we expect only 1 or 2 parts + if {[llength $parts] == 2} { + lassign $parts domain username + + #if we use username@domain format - we get the domain controller's view of our home directory - which can be different from the local machine's view of our home directory. + #e.g file tildeexpand ~jnoble@corp can return a local non existant path like c:/users/jnoble + #but it may be c:/users/jnoble.corp - or c:/users/something_else_entirely depending on how the local machine is configured. + #It may be that the domain controller is correct if it returns a network path like \\server\users\jnoble ?? + #Network paths are not necessarily the preferred practive as of 2026 - but may still exist. + #Microsoft is encouraging the use of cloud systems - but it it unknown at this stage what sort of paths can be returned. + + #REVIEW + + set domainuser "$username@$domain" + #we can run file tildeexpand with username@domain and test if the path is writable + #this reduces the possibility that there happens to be a local user with the same name as the domain user - which would cause us to get the wrong home directory. + if {![catch {file tildeexpand ~$domainuser} path]} { + if {[file writable $path]} { + set user $domainuser + set hdir $path ;#set hdir so we don't re-lookup below. + } + } + if {$hdir eq ""} { + #for now we will use the unqualified username. + set user $username + } + + } elseif {[llength $parts] == 1} { + set user [lindex $parts 0] + } else { + #unexpected format - emit warning + puts stderr "Warning: Unexpected format of username '$user' returned by whoami. Expected format 'DOMAIN\\USER' or 'USER'. Unable to determine home directory for this user." + set user "" + } + } + + #only enter this branch if hdir wasn't resolved above for windows domain user. + if {$hdir eq "" && $user ne ""} { + #we use file tildeexpand ~user because the intention is stated in the tcl source as: + #* the intent is to retrieve (as on Unix) the system's view + #* of the home irrespective of environment settings of HOME + #* and USERPROFILE. + # - this aligns with our intention here. + if {![catch {file tildeexpand ~$user} path]} { + set hdir [punk::valcopy $path] + } else { + #tcl <= 8.6 may not have file tildeexpand. + #we now have no option but to rely on environment variables - which may not be set or may be set to an incorrect value + #as tcl <= 8.6 needs to be supported - but isn't the primary target we will allow this fallback - but raise a warning as this is not ideal. + puts stderr "punk::nav::fs::~ Warning: Unable to determine home directory for user '$user' using 'file tildeexpand ~$user'. Falling back to environment variables, which may not be set or may be incorrect. Consider upgrading to Tcl 9.0 or later for improved reliability." + if {"windows" eq $::tcl_platform(platform)} { + if {[info exists ::env(USERPROFILE)]} { + set hdir [punk::valcopy $::env(USERPROFILE)] + } else { + set hdir "" + } + } else { + if {[info exists ::env(HOME)]} { + set hdir [punk::valcopy $::env(HOME)] + } else { + set hdir "" + } + } + } + } + } + } + + if {$hdir eq ""} { + error "punk::nav::fs::~ Unable to determine home directory for user '$user'. Consider upgrading to Tcl 9.0 or later for improved reliability in home directory detection." + } + + file pathtype $hdir ;#flips internal-rep to path + if {![file isdirectory $hdir]} { + #file isdirectory should also return true if the path exists and is a symlink to a directory - but if it doesn't exist at all - or is a file - then we have a problem. + error "punk::nav::fs::~ Determined home directory path '$hdir' does not exist (or is not a directory)." + } else { + if {![file readable $hdir]} { + error "punk::nav::fs::~ Determined home directory path '$hdir' is not readable." + } + } + + set user_home_cache $hdir ;#cache only the home directory. + + set d $hdir + #use the file join 2-arg optimisation to avoid losing path-rep - probably doesn't give any advantage on all Tcl versions + #review - for what versions does/did the 2-arg version of file join not just return a string? + foreach a $args { + set d [file join $d $a] + } + file pathtype $d + return [punk::valcopy $d] + } + punk::args::define { @id -id ::punk::nav::fs::d/ @cmd -name punk::nav::fs::d/ -help\ @@ -624,9 +795,11 @@ tcl::namespace::eval punk::nav::fs { return $result } + + #---------------------------------------------------- punk::args::define { - @id -id ::punk::nav::fs::d/new - @cmd -name punk::nav::fs::d/new\ + @id -id ::punk::nav::fs::newdir + @cmd -name punk::nav::fs::newdir\ -summary\ "Create directory or directories at the specified path(s)."\ -help\ @@ -662,9 +835,9 @@ tcl::namespace::eval punk::nav::fs { created for some reason (e.g other filesystem error) then an error will be raised and processing of any remaining paths will be aborted." } - #todo - synchronize overall behaviour of d/new with that of n/new (for namespaces) - proc d/new {args} { - set argd [punk::args::parse $args withid ::punk::nav::fs::d/new] + #todo - synchronize overall behaviour of newdir with that of newns (for namespaces) + proc newdir {args} { + set argd [punk::args::parse $args withid ::punk::nav::fs::newdir] lassign [dict values $argd] leaders opts values received set paths [dict get $values path] set allow_nonportable [dict exists $received -nonportable] @@ -678,12 +851,12 @@ tcl::namespace::eval punk::nav::fs { set error_paths [list] foreach p $paths { if {!$allow_nonportable && [punk::winpath::illegalname_test $p]} { - #error "punk::nav::fs::d/new Path '$p' is not portable and may not be created without -nonportable option" + #error "punk::nav::fs::newdir Path '$p' is not portable and may not be created without -nonportable option" lappend error_paths [list $p "Path '$p' is not portable and may not be created without -nonportable option"] continue } if {[string first \0 $p] != -1} { - #error "punk::nav::fs::d/new Path '$p' contains null character which is not allowed" + #error "punk::nav::fs::newdir Path '$p' contains null character which is not allowed" lappend error_paths [list $p "Path '$p' contains null character which is not allowed"] continue } @@ -699,7 +872,7 @@ tcl::namespace::eval punk::nav::fs { set parent [file dirname $parent] } if {![file writable $parent]} { - #error "punk::nav::fs::d/new Cannot create directory '$fullpath' as parent '$parent' is not writable" + #error "punk::nav::fs::newdir Cannot create directory '$fullpath' as parent '$parent' is not writable" lappend error_paths [list $fullpath "Cannot create directory '$fullpath' as parent '$parent' is not writable"] continue } @@ -713,7 +886,7 @@ tcl::namespace::eval punk::nav::fs { set m [lindex $e 1] append path_error_display " Path: '$p' Error: $m\n" } - error "punk::nav::fs::d/new One or more supplied paths were invalid or not writable:\n$path_error_display" + error "punk::nav::fs::newdir One or more supplied paths were invalid or not writable:\n$path_error_display" } set num_created 0 @@ -730,17 +903,56 @@ tcl::namespace::eval punk::nav::fs { incr num_created } if {$error_string ne ""} { - error "punk::nav::fs::d/new $error_string\n$num_created directories out of [llength $fullpath_list] were created successfully before the error was encountered." + error "punk::nav::fs::newdir $error_string\n$num_created directories out of [llength $fullpath_list] were created successfully before the error was encountered." } #display summaries of created directories (which may have already existed) by reusing d/ to get info on them. set query_paths [lmap v $paths {string cat $v "/*"}] d/ / {*}$query_paths } + #---------------------------------------------------- + - #todo use unknown to allow d/~c:/etc ?? - proc d/~ {args} { - set home $::env(HOME) + punk::args::define { + @id -id ::punk::nav::fs::lib::gohome + @cmd -name punk::nav::fs::lib::gohome\ + -summary\ + "Navigate to a path relative to the current user's home directory."\ + -help\ + "Navigate to a path relative to the user's home directory. + + This may usually correspond to the HOME environment variable, but some + tools may have pointed HOME elsewhere, so the home directory is determined + based on the current user as determined using the whoami command, which is + almost universally available on platforms that Tcl runs on, and should be + unaffected by any changes to environment variables. + + This is a convenience function for quickly navigating to commonly used + locations within the home directory, without having to type out the full + path or use environment variables. + + Like the './' command, this navigates to the folder and then lists the sub-directories, + with a summary of the number of sub-directories and files, and total file size in bytes. + + " + @values -min 1 -max -1 + path -type string -optional 1 -multiple 1 -help\ + "Path relative to home directory to navigate to. + If the path does not exist, or is not a directory, then an error will be raised. + Examples: + gohome - will navigate to $HOME + (equivalent: gohome .) + gohome subdir1/subdir2 - will navigate to $HOME/subdir1/subdir2 + (equivalent: gohome subdir1 subdir2) + gohome subdir1 - will navigate to $HOME/subdir1 + + An absolute path is also accepted, but then the navigation is not relative to the home + directory and is effectively just a normal navigation to the specified path. + (equivalent to using ./ ) + " + } + proc gohome {args} { + set home [punk::nav::fs::~] set target [file join $home {*}$args] if {![file isdirectory $target]} { error "Folder $target not found" @@ -1731,10 +1943,11 @@ tcl::namespace::eval punk::nav::fs { if {![catch {package require punk::winlnk}]} { set target_type "file" ;#default/fallback - set shortcutinfo [punk::winlnk::resolve $fname] - if {[dict exists $shortcutinfo link_target]} { + set shortcutinfo [punk::winlnk::resolve $fname] ;#will always return a dict. Will only contain error key if there was an error. + + if {[dict exists $shortcutinfo link_roottarget]} { set is_valid_lnk 1 - set tgt [dict get $shortcutinfo link_target] + set root_tgt [dict get $shortcutinfo link_roottarget] set link_target_type [dict get $shortcutinfo target_type] switch -- $link_target_type { file { @@ -1744,12 +1957,12 @@ tcl::namespace::eval punk::nav::fs { set target_type "directory" } unknown { - #fall back to checking attributes and filesystem if we have a link_target but no target_type - if {[file exists $tgt]} { + #fall back to checking attributes and filesystem if we have a link_roottarget but no target_type + if {[file exists $root_tgt]} { #file type could return 'link' - we will use isfile/isdirectory - if {[file isfile $tgt]} { + if {[file isfile $root_tgt]} { set target_type file - } elseif {[file isdirectory $tgt]} { + } elseif {[file isdirectory $root_tgt]} { set target_type directory } else { set target_type file ;## ? @@ -1761,26 +1974,32 @@ tcl::namespace::eval punk::nav::fs { } } } else { - #no link_target - probably an ordinary file - but there could have been some other error in reading the binary windows lnk format. + #no link_roottarget - probably an ordinary file - but there could have been some other error in reading the binary windows lnk format. set is_valid_lnk 0 } if {$is_valid_lnk} { switch -- $target_type { file { set display [dict get $fdict display] - set display "$fshortcut_style$display (shortcut $tgt)" ;# + if {[dict exists $shortcutinfo stringdata command_line_arguments]} { + set display "$fshortcut_style$display (shortcut to $root_tgt [dict get $shortcutinfo stringdata command_line_arguments])" + } else { + set display "$fshortcut_style$display (shortcut $root_tgt)" ;# + } dict set fdict display $display lappend finfo_plus $fdict } directory { #target of link is a dir - for display/categorisation purposes we want to see it as a dir #will be styled later based on membership of dir_shortcuts + #review: we shouldn't see a link to a dir that also has command_line_arguments + #- but if we do, we will just ignore the command_line_arguments for now and treat as a directory shortcut. lappend dirs $fname lappend dir_shortcuts $fname } } } else { - #we were unable to get link_target - but we still need to check if it failed the header check (then assume not intended to be a windows shell lnk) or for some other reason. + #we were unable to get link_roottarget - but we still need to check if it failed the header check (then assume not intended to be a windows shell lnk) or for some other reason. if {[dict exists $shortcutinfo error]} { if {[dict get $shortcutinfo error] ne "lnk_header_check_failed"} { #Presumably there is a valid lnk header, but some unexpected error occurred - show it in the display for the file @@ -1794,9 +2013,10 @@ tcl::namespace::eval punk::nav::fs { lappend finfo_plus $fdict } } else { - #shouldn't ever happen. If no error, then there should have been a link_target + #shouldn't ever happen. If no error, then there should have been a link_roottarget #report and move on - puts stderr "Unexpected error in result of parsing binary format for $fname" + puts stderr "Unexpected error in result of parsing binary format for $fname." + puts stderr "Result was [showdict $shortcutinfo]" lappend finfo_plus $fdict } } @@ -2079,6 +2299,7 @@ tcl::namespace::eval punk::nav::fs::system { } +interp alias {} ~ {} punk::nav::fs::~ interp alias {} ./ {} punk::nav::fs::d/ / interp alias {} d/ {} punk::nav::fs::d/ / interp alias {} .// {} punk::nav::fs::d/ // @@ -2093,10 +2314,12 @@ interp alias {} dirfiles {} punk::nav::fs::dirfiles interp alias {} dirfiles_dict {} punk::nav::fs::dirfiles_dict interp alias {} fglob {} punk::nav::fs::fglob -interp alias {} ./new {} punk::nav::fs::d/new -interp alias {} d/new {} punk::nav::fs::d/new -interp alias {} ./~ {} punk::nav::fs::d/~ -interp alias {} d/~ {} punk::nav::fs::d/~ +interp alias {} newdir {} punk::nav::fs::newdir + +#this also conflicts with auto_cd as there could be a local folder (or file) called ~. +interp alias {} gohome {} punk::nav::fs::gohome + +#review interp alias {} x/ {} punk::nav::fs::x/ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ diff --git a/src/vfs/_vfscommon.vfs/modules/punk/nav/ns-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/nav/ns-0.1.0.tm index 16cb13a1..6a336808 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/nav/ns-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/nav/ns-0.1.0.tm @@ -94,7 +94,8 @@ tcl::namespace::eval punk::nav::ns { if {[llength $ensemble_info] > 0} { #this namespace happens to match ensemble command. #todo - keep cache of encountered ensembles from commands.. and examine namespace in the configure info. - set ns_display "\n[a+ yellow bold]$ns_current (ensemble)[a+]" + #don't rely on a+ alias here. + set ns_display "\n[punk::ansi::a+ yellow bold]$ns_current (ensemble)[punk::ansi::a+]" } } } @@ -103,11 +104,86 @@ tcl::namespace::eval punk::nav::ns { return $out } - #create possibly nested namespace structure - but only if not already existant - proc n/new {args} { + #create possibly nested namespace structure(s) - todo: allow specifying namespaces or which already or partially already exist. + #todo - sync with newdir behaviour. + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::punk::nav::ns::newns + @cmd -name punk::nav::ns::newns\ + -summary\ + "Create namespace or namespaces at the specified path(s)."\ + -help\ + "This command creates namespaces at the specified path(s). + If any part of the specified path does not exist, then it will be created as well. + If a specified path already exists, then it will be left as-is and no error will be raised. + + A summary line is returned for each created namespace, with the full path of the created + namespace and a status line indicating the number of child namespaces, commands and vars in + the namespace if it already existed (or showing 0 for all if it was just created). + (summary incomplete - todo)" + -force -type none\ + -help\ + "Allows creation of namespaces which may be unwise/problematic, such as empty string + or namespaces with leading colons. + Use with caution and only when you know what you are doing. + If -force is not supplied, then an error will be raised if any supplied + path is problematic and no namespaces will be created." + @values -min 1 -max -1 -type string + path -type string -multiple 1 -optional 0 -help\ + "Path(s) (possibly with namespace separator ::) to create. + Can be absolute or relative to current namespace. + If any path is rejected, then no namespaces will be created. + + If a namespace or part of a namespace already exists, then it will be left as-is and no + error will be raised. + + If despite passing the name tests, a namespace cannot be created for some reason then an + error will be raised and processing of any remaining paths will be aborted." + }] + } + proc newns {args} { + set argd [punk::args::parse $args withid ::punk::nav::ns::newns] + lassign [dict values $argd] _leaders opts values _received + if {[dict exists $opts -force]} { + set opt_force [dict get $opts -force] + } else { + set opt_force 0 + } + set paths [dict get $values path] + + variable ns_current + + #todo: like newdir we want to try to perform an all-or-nothing operation - so first validate all namespaces to be created before creating any of them. + + set ns [lindex $paths 0] ;#temporary - full implementation will loop through $paths. + set is_absolute [string match ::* $ns] + if {$is_absolute} { + set nspath $ns + } else { + if {[string match :* $ns]} { + #todo - disallow by default and require flag to force. + #we also should disallow by default ::: (or any odd multiple? perhaps even :::: for empty ns should require -force) in between segments. + puts stderr "newns WARNING namespace with leading colon '$ns' is likely to have unexpected results" + } + set nspath [nsjoin $ns_current $ns] + } + + set ns_exists [nseval [nsprefix $nspath] [list ::tcl::namespace::exists [nstail $nspath] ]] + + if {$ns_exists} { + error "Namespace $nspath already exists" + } + #tcl::namespace::eval [nsprefix $nspath] [list tcl::namespace::eval [nstail $nspath] {}] + nseval [nsprefix $nspath] [list ::tcl::namespace::eval [nstail $nspath] {}] + + #display summaries of created directories (which may have already existed) by reusing d/ to get info on them. + set query_paths [lmap v $paths {string cat $v "::*"}] + ns/ / {*}$query_paths + } + proc newns_old {args} { variable ns_current if {![llength $args]} { - error "usage: :/new \[ ...\]" + error "usage: newns \[ ...\]" } set a1 [lindex $args 0] set is_absolute [string match ::* $a1] @@ -115,7 +191,7 @@ tcl::namespace::eval punk::nav::ns { set nspath [nsjoinall {*}$args] } else { if {[string match :* $a1]} { - puts stderr "n/new WARNING namespace with leading colon '$a1' is likely to have unexpected results" + puts stderr "newns WARNING namespace with leading colon '$a1' is likely to have unexpected results" } set nspath [nsjoinall $ns_current {*}$args] } @@ -130,6 +206,7 @@ tcl::namespace::eval punk::nav::ns { n/ $nspath } + #nn/ ::/ nsup/ - back up one namespace level proc nsup/ {v args} { variable ns_current @@ -160,14 +237,13 @@ tcl::namespace::eval punk::nav::ns { interp alias {} n/ {} punk::nav::ns::ns/ / interp alias {} n// {} punk::nav::ns::ns/ // interp alias {} n/// {} punk::nav::ns::ns/ /// -interp alias {} n/new {} punk::nav::ns::n/new +interp alias {} newns {} punk::nav::ns::newns interp alias {} nn/ {} punk::nav::ns::nsup/ / interp alias {} nn// {} punk::nav::ns::nsup/ // if 0 { -#we can't have ::/ without just plain / which is confusing. interp alias {} :/ {} punk::nav::ns::ns/ / interp alias {} :// {} punk::nav::ns::ns/ // -interp alias {} :/new {} punk::nav::ns::n/new +#we can't have ::/ without just plain / which is confusing. interp alias {} ::/ {} punk::nav::ns::nsup/ / interp alias {} ::// {} punk::nav::ns::nsup/ // } diff --git a/src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.1.tm index e5033e18..47a42719 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.1.tm @@ -1323,13 +1323,15 @@ tcl::namespace::eval punk::netbox { proc _homedir {} { - if {[info exists ::env(HOME)]} { - set home [file normalize $::env(HOME)] - } else { - #not available on 8.6? ok will error out here. - set home [file tildeexpand ~] - } - return $home + package require punk::nav::fs + punk::nav::fs::~ + #if {[info exists ::env(HOME)]} { + # set home [file normalize $::env(HOME)] + #} else { + # #not available on 8.6? ok will error out here. + # set home [file tildeexpand ~] + #} + #return $home } lappend PUNKARGS [list { @id -id ::punk::netbox::_datafile @@ -1367,23 +1369,33 @@ tcl::namespace::eval punk::netbox { lassign [dict values $argd] leaders opts values received set be_quiet [dict exists $received -quiet] + set data_home "" set was_noisy 0 if {[info exists ::env(XDG_DATA_HOME)]} { set data_home $::env(XDG_DATA_HOME) } else { if {$::tcl_platform(platform) eq "windows"} { - set data_home $::env(LOCALAPPDATA) + if {[info exists ::env(LOCALAPPDATA)]} { + set data_home $::env(LOCALAPPDATA) + } else { + if {!$be_quiet} { + puts stderr "Environment variable LOCALAPPDATA does not exist - consider setting it if /.local/share is not a suitable location" + set was_noisy 1 + } + } } else { - set data_home [file join [_homedir] .local share] if {!$be_quiet} { - puts stderr "Environment variable XDG_DATA_HOME does not exist - consider setting it if $data_home is not a suitable location" + puts stderr "Environment variable XDG_DATA_HOME does not exist - consider setting it if /.local/share is not a suitable location" set was_noisy 1 } } + if {$data_home eq ""} { + set data_home [file join [_homedir] .local share] + } } if {!$be_quiet && ![file exists $data_home]} { #parent folder for 'punk' config dir doesn't exist - set msg "configuration location XDG_DATA_HOME or ~/.local/share (or LOCALAPPDATA on windows) at path '$data_home' does not yet exist" + set msg "configuration location XDG_DATA_HOME or /.local/share (or LOCALAPPDATA on windows) at path '$data_home' does not yet exist" append msg \n " - please create it and/or set the appropriate env var." puts stderr $msg set was_noisy 1 diff --git a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm index 883f82de..b90c3b3b 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm @@ -3416,8 +3416,8 @@ y" {return quirkykeyscript} lappend usageinfo $c set found_documentation 1 } - #todo - alias to an alias - #e.g n/new jjj + #todo? - alias to an alias + #e.g newns jjj # interp alias "" ::jjj::corp2 "" ::corp #todo -pseudocode #cmdwhich id diff --git a/src/vfs/_vfscommon.vfs/modules/punk/winlnk-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/winlnk-0.1.1.tm index 7ad2ba89..6c31f56a 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/winlnk-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/winlnk-0.1.1.tm @@ -75,6 +75,10 @@ tcl::namespace::eval punk::winlnk { #[para] Core API functions for punk::winlnk #[list_begin definitions] + #todo - review internal API. + #A lot of these functions accept the raw contents of a .lnk file. + #It may make sense to use an OO approach to avoid reparsing of contents when calling multiple functions on the same .lnk file. + variable magic_HeaderSize "0000004C" ;#HeaderSize MUST equal this variable magic_LinkCLSID "00021401-0000-0000-C000-000000000046" ;#LinkCLSID MUST equal this @@ -853,14 +857,14 @@ tcl::namespace::eval punk::winlnk { set suffix_path "" set linkinfocontent [dict get $linkinfo_content_dict content] set next_start [dict get $linkinfo_content_dict next_start] ;#location of section following LinkInfo (Location information) - this will be the Data Strings. - set link_target "" + set link_roottarget "" set linkfields [dict create] if {$linkinfocontent ne ""} { set linkfields [LinkInfo_get_fields $linkinfocontent] set localbase_path [dict get $linkfields localbasepath] set suffix_path [dict get $linkfields commonpathsuffix] if {"windows" eq $::tcl_platform(platform)} { - set link_target [file join $localbase_path $suffix_path] + set link_roottarget [file join $localbase_path $suffix_path] } else { #review - calling mount and parsing its output every time we parse a .lnk file makes this slow on large folders with .lnk files # - we may want to cache the results of mount for some period of time or until we detect a change in the system's mounts (e.g. by monitoring /proc/mounts for changes or using a filesystem watcher on /mnt) @@ -868,24 +872,24 @@ tcl::namespace::eval punk::winlnk { if {[regexp {([a-zA-Z]):\\(.*)} $localbase_path _match drive_letter tail]} { set localbase_path [string map {\\ /} $localbase_path] set tail [string trimleft [string map {\\ /} $tail] /] - set link_target "" + set link_roottarget "" #shortcut basepath is a windows path with drive letter - try to resolve it on unix by looking for a corresponding mount from fstab or a point under /mnt set mountinfo [exec mount] foreach line [split $mountinfo "\n"] { #review - a more specific mount target might exist that includes the drive letter as part of the mount point name and is a longer prefix of the localbase_path #- we should probably look for the longest prefix match rather than just the drive letter if {[regexp -nocase -- [string cat ^$drive_letter {:\\\s+on\s+(\S+)}] $line _match mount_point]} { - set link_target [file join $mount_point $tail $suffix_path] + set link_roottarget [file join $mount_point $tail $suffix_path] break } } - if {$link_target eq ""} { + if {$link_roottarget eq ""} { #review - under what circumstances could this happen? If the drive letter doesn't match any mount points, then /mnt/drive_letter should generally already have been found above above # - However, it may be possible for /mnt/drive_Letter to still exist even if it's not reflected in the output of mount or the output of mount is in an unexpected format. #nothing in mount result matches the drive letter - try looking for a mount point under /mnt with the drive letter as the name if {[file exists /mnt/$drive_letter]} { - set link_target [file join /mnt/$drive_letter $tail $suffix_path] + set link_roottarget [file join /mnt/$drive_letter $tail $suffix_path] } else { if {$drive_letter eq [string tolower $drive_letter]} { set op_drive_letter [string toupper $drive_letter] @@ -893,20 +897,20 @@ tcl::namespace::eval punk::winlnk { set op_drive_letter [string tolower $drive_letter] } if {[file exists /mnt/$op_drive_letter]} { - set link_target [file join /mnt/$op_drive_letter $tail $suffix_path] + set link_roottarget [file join /mnt/$op_drive_letter $tail $suffix_path] } else { #leave as is except for backslashes converted to forward #- probably won't resolve correctly unless the unix system has a folder named drive_letter: in the current folder with a copy of the original filestructure. - set link_target [file join $localbase_path $suffix_path] + set link_roottarget [file join $localbase_path $suffix_path] } } } else { - #shortcut basepath is a windows path with drive letter and we found a matching mount point - link_target is set to the resolved path + #shortcut basepath is a windows path with drive letter and we found a matching mount point - link_roottarget is set to the resolved path } } else { #shortcut basepath doesn't match expected windows path format - just join it with the suffix and hope for the best #could be something like a network path or it could be something else entirely - set link_target [file join $localbase_path $suffix_path] + set link_roottarget [file join $localbase_path $suffix_path] } } } @@ -929,14 +933,14 @@ tcl::namespace::eval punk::winlnk { set target_type [dict get $target_type_info type] set target_type_mech [dict get $target_type_info mechanism] if {$target_type eq "unknown"} { - if {[file exists $link_target]} { - set target_type [file type $link_target] + if {[file exists $link_roottarget]} { + set target_type [file type $link_roottarget] set target_type_mech "filesystem" } } set result [dict create\ - link_target $link_target\ + link_roottarget $link_roottarget\ link_flags $flags_enabled\ file_attributes $file_attributes\ creation_time [Header_Get_CreationTime $contents]\ @@ -1017,7 +1021,7 @@ tcl::namespace::eval punk::winlnk { package require punk::lib #punk::lib::showdict [resolve $path] */@* set field_queries [dict create\ - link_target link_target\ + link_roottarget link_roottarget\ link_flags link_flags/@*\ file_attributes file_attributes\ creation_time creation_time\ @@ -1055,32 +1059,33 @@ tcl::namespace::eval punk::winlnk { @id -id ::punk::winlnk::target @cmd -name punk::winlnk::target\ -summary\ - "Return the target path of a .lnk file (windows shortcut)"\ + "Return the target path/commandline of a .lnk file (windows shortcut)"\ -help\ - "Return the target path of the .lnk file specified in path. + "Return the target path/commandline of the .lnk file specified in path. This is a convenience function that extracts the target path from the .lnk file and returns it directly, without all the additional information that resolve provides. If the .lnk header check fails, then - the .lnk file probably isn't really a shortcut file and an error message will be returned. - - Incomplete! - needs to process arguments when HasArguments link flag is set and append the arguments to the target path. - - e.g for a shortcut to 'START /D ...' the target will currently just return a path to cmd.exe - which is insufficient." + the .lnk file probably isn't really a shortcut file and an error message will be returned." @values -min 1 -max 1 path -type string -help "Path to the .lnk file to resolve" }] } + #consider a shortcut to the following: # START /D ^"C:\tcl\bin^" wish.exe c:\cmdfiles\ftp.tcl" - # the target currently only returns c:/Windows/System32/cmd.exe. + # the link_roottarget is c:/Windows/System32/cmd.exe. + proc target {path} { - #*** !doctools - #[call [fun target] [arg path] ] - #[para]Return the target path of the .lnk file specified in path set info [resolve $path] if {[dict exists $info error]} { error [dict get $info error] } else { - return [dict get $info link_target] + set roottarget [dict get $info link_roottarget] + if {[dict exists $info stringdata command_line_arguments]} { + set arguments [dict get $info stringdata command_line_arguments] + return "$roottarget $arguments" + } else { + return $roottarget + } } } @@ -1094,7 +1099,9 @@ tcl::namespace::eval punk::winlnk { } proc Get_target_type {content file_attributes} { - #determine type based on info in the .lnk file, such as file attributes and link flags + #determine target file/directory/link type based on info in the .lnk file, such as file attributes and link flags + #review - a .lnk may target an executable with arguments. + #In this case, the target type may be considered a file (the executable) but it may also be useful to indicate that it's a link to an executable with arguments(?). if {"DIRECTORY" in $file_attributes} { return [dict create type directory mechanism file_attributes]" @@ -1104,31 +1111,31 @@ tcl::namespace::eval punk::winlnk { set iteminfo [Get_LinkTargetIDList_iteminfo $content] if {[llength $iteminfo] > 0} { set first_item [lindex $iteminfo 0] - set first_item_type [dict get $first_item type] + set first_item_type [dict get $first_item typehex] set saw_2f 0 switch -- $first_item_type { "1F" { #plain files and folders always seem to have a first item type of 1F #so does "local disk" - set type_so_far "unknown" - #For a file, we may first see multiple items of type 32 (directory) as we go through the folder structure, - #and then finally an item of type 31 (file) at the end. + set target_type_so_far "unknown" + #For a file, we may first see multiple items of typehex 32 (directory) as we go through the folder structure, + #and then finally an item of typehex 31 (file) at the end. #For a network location, we may see an item of type 2F. #So we need to loop through all the items and keep track of what we've seen so far. foreach item $iteminfo { - set item_type [dict get $item type] - if {$item_type eq "31"} { - set type_so_far "directory" - } elseif {$item_type eq "32"} { + set item_type_hex [dict get $item typehex] + if {$item_type_hex eq "31"} { + set target_type_so_far "directory" + } elseif {$item_type_hex eq "32"} { return [dict create type file mechanism idlist] - } elseif {$item_type eq "2F"} { + } elseif {$item_type_hex eq "2F"} { set saw_2f 1 } } - if {$type_so_far eq "unknown" && $saw_2f} { + if {$target_type_so_far eq "unknown" && $saw_2f} { return [dict create type "local disk" mechanism idlist] } - return [dict create type $type_so_far mechanism idlist] + return [dict create type $target_type_so_far mechanism idlist] } } return [dict create type "unknown" mechanism idlist] diff --git a/src/vfs/_vfscommon.vfs/modules/test/punk/args-0.1.5.tm b/src/vfs/_vfscommon.vfs/modules/test/punk/args-0.1.5.tm index 5996a6ef9cfb1da147209a9ff0d323644e6aaae1..675d1e2dc67235c9ade70fdb2b7f49bac77d24a2 100644 GIT binary patch delta 1576 zcmV+@2G{xJlmYdX0k9Ps11A=Ivltrg7ZVv4d|YS&xl}L(002}Y0024w1(RS!FOx_z z5`S62ZsRr(y$8rY43Y)X7EoKeH=p_udsrYF2sAaeh)|?TQb}Ax|K1@f$(F1HRvd4W zV0}nrX*e@)=JAn~OUCcn8o}T{l`sg7ONZ87UR+)%R-i2zN5BUrVX^QJ;*IU)1<+?_ zA&OEP=WXKn#p1VU^1zH>ONqdBQE1hU^nV|Vj>6hXI=H%uw`(6aUV1OUb1gX9)NM)> zYo!fl>0^#6jSo_xQYpx8`_)^!oHwvCh3?Ue|a1fRdFZs;sT*Z5Y0$ zEWU&^VwAhK!X1)1;1lCbNt#N%0uN>N|3PZ)du`+rnW9E+pLyOo^&I-%kGq$5L^k31 z-Lo7{8$t@*QkYV3hA?3^8)b2y!GDpzx^h-z^ncYj4|8D2ELnNF4m}@3?FpTp&5mfZ zQ0_1h`19;!7Ax4^@<8Olg!P{hH2EsYj%2ak-Gta1*)Q!Qzac&=DG(TBd=ZDf7 z)Z_>1Yj4_EDibjKa{l`(Ljudn1$xucT+lYiZ>LI$PY}S|cr-U;6?SM4(k+d4R77&; zVRCH@eVd^2+gw6YPh8MHzJJue2F*{cKh*kA$FmClsRaG0`fslKO-s(D{Qlp8`lkgY zCP)iYPlTofrNNbWf^D$t+8p$Asp(JB4gxA$YY+!b7V{7zxL#Gn_Bb1wkiSnlKyg%b zk)h>AlwP?<$nA6~IP6ik9mcgHD$p{ajqUsB!Sl55z|Y`~PLR7A#D6H1ShsjitU<{A z0|GBv)O#%OB==*<-};u@Xd^$)h)v*{X9AIj{t)0u`u zX->P|xUC%7dGEBhtNJv_ZSPGL-4{v5V9SBk{$dGyY=`izJCK^NW9j(DXb6p=$+pj< zL9%q#gulo_hbl4&vwwF(v~K~zmJ|L^fELdF9<|?LA`K5`9R;+na5n#o=tkVHU&gi0dlzOa7t+6}^JjK*}Nhu~v_s5{$_3L+-(o;&eoE5Qy-FX#Fl*xenuKBSe}EA8aP zB4|+4+tD|AulU6;>|_pow)~j%BMLknCu$MFo>wMl}LzA(LT8E0ga<1(U-@GXm=)lVL|IlkY_Z zlPE_w0v;%nVMl=im?)EBM>3NZNKF9{lkrJ1lh{HklfXzS0g#jNNivfiNm2p~DwAz0H0k9Ps1JWHavltrg7Zdz;@LKrh2#lTt007q=0024w1(WbaFOx_z z5`S1tZ{s!)y$8sD7$gg%TR>>--hA30v4;h+hCoRpiwH%kB$e0|^xr!qC4b0DV8wBp z1gk?Li^Ji(na4MjDwaO56@tdUYpxM&Dl8g%eRX{$S&61%DFQw+0gHtj2oIX;E1+v< z!OKc%>ukdO#p3s1^2ju2i9kqISt{AjbbpsYOUs&CSh%?fk6X8HxOHA2Efi1D#CB65 zUrD7gi=PUVaTtiXj0GpV=DV}D1+x%2Ti^zyvb4J38MBx{t~4O`$ny zyBF?k7%Uxk;4iXJl@oY+IiJ0o_og2nLX#4HpMW0DzD#!O-ddF@5`T~kQ{QeS5VdWA z`Uq~25ZcLx389`Kt1H1tHYj0S_85~5dCD2xj($Z5{6K*vN*kww)n=3`^zQ4&B7t&6 zzgHS*A?*$i5@wTo{r7^xcl~}_V&9&bcw!p^R3*XbnN@&{M6kp%p|$Ab5$F+7N;o~| z#_4A_iIPPn5AW$7RDaZ=>LMRR(7n(Hz?5M+J@~cyNdi8t#6J1_?^x9`Ai zd18NvYq^)&$<4xRP*>a0m&#XsboM8iW1l@gCVj_)^=YEUeOF-m85;T{^Vmz%TkNOX zX^4C%pAFOJLM9ZV`DD~9J{uqg#rpQ%5rbTO*V4M=O)iHwBZpM>hhFCzJ6cx0ZM-Y^eL0^M=_J!L@blv MN)QHgDgXcg04}|Z&j0`b