From 077059e04338ddfaee2cc756938b342613125a3f Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Wed, 8 Jul 2026 17:36:37 +1000 Subject: [PATCH] update bootsupport and vfs --- .../modules/{punk-0.1.1.tm => punk-0.2.0.tm} | 1002 +++++++++-------- .../modules/punk/args-0.2.3.tm} | 50 +- .../modules/punk/ns-0.1.1.tm} | 14 +- .../modules/punk/packagepreference-0.1.1.tm} | 10 +- .../punk/{path-0.2.1.tm => path-0.2.2.tm} | 94 +- ...llfilter-0.2.3.tm => shellfilter-0.2.4.tm} | 9 +- .../modules/shellthread-1.6.3.tm} | 20 +- .../modules/tomlish-1.1.10.tm} | 200 +++- .../src/bootsupport/modules/punk-0.2.0.tm} | 1002 +++++++++-------- .../bootsupport/modules/punk/args-0.2.3.tm} | 50 +- .../src/bootsupport/modules/punk/ns-0.1.1.tm} | 14 +- ...ce-0.1.0.tm => packagepreference-0.1.1.tm} | 10 +- .../bootsupport/modules/punk/path-0.2.2.tm} | 94 +- ...llfilter-0.2.3.tm => shellfilter-0.2.4.tm} | 9 +- .../bootsupport/modules/shellthread-1.6.3.tm} | 20 +- .../{tomlish-1.1.8.tm => tomlish-1.1.10.tm} | 200 +++- .../src/bootsupport/modules/punk-0.2.0.tm} | 1002 +++++++++-------- .../bootsupport/modules/punk/args-0.2.3.tm} | 50 +- .../src/bootsupport/modules/punk/ns-0.1.1.tm} | 14 +- .../modules/punk/packagepreference-0.1.1.tm} | 10 +- .../bootsupport/modules/punk/path-0.2.2.tm} | 94 +- ...llfilter-0.2.3.tm => shellfilter-0.2.4.tm} | 9 +- .../bootsupport/modules/shellthread-1.6.3.tm} | 20 +- .../bootsupport/modules/tomlish-1.1.10.tm} | 200 +++- .../modules/{punk-0.1.1.tm => punk-0.2.0.tm} | 1002 +++++++++-------- .../modules/punk/args-0.2.3.tm} | 50 +- .../_vfscommon.vfs/modules/punk/ns-0.1.1.tm} | 14 +- 27 files changed, 3248 insertions(+), 2015 deletions(-) rename src/bootsupport/modules/{punk-0.1.1.tm => punk-0.2.0.tm} (94%) rename src/{project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm => bootsupport/modules/punk/args-0.2.3.tm} (99%) rename src/{project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm => bootsupport/modules/punk/ns-0.1.1.tm} (99%) rename src/{project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm => bootsupport/modules/punk/packagepreference-0.1.1.tm} (98%) rename src/bootsupport/modules/punk/{path-0.2.1.tm => path-0.2.2.tm} (93%) rename src/bootsupport/modules/{shellfilter-0.2.3.tm => shellfilter-0.2.4.tm} (99%) rename src/{project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellthread-1.6.2.tm => bootsupport/modules/shellthread-1.6.3.tm} (97%) rename src/{project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/tomlish-1.1.8.tm => bootsupport/modules/tomlish-1.1.10.tm} (98%) rename src/project_layouts/custom/_project/{punk.shell-0.1/src/bootsupport/modules/punk-0.1.1.tm => punk.project-0.1/src/bootsupport/modules/punk-0.2.0.tm} (94%) rename src/{bootsupport/modules/punk/args-0.2.1.tm => project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.3.tm} (99%) rename src/{vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm => project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.1.tm} (99%) rename src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/{packagepreference-0.1.0.tm => packagepreference-0.1.1.tm} (98%) rename src/project_layouts/custom/_project/{punk.shell-0.1/src/bootsupport/modules/punk/path-0.2.1.tm => punk.project-0.1/src/bootsupport/modules/punk/path-0.2.2.tm} (93%) rename src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/{shellfilter-0.2.3.tm => shellfilter-0.2.4.tm} (99%) rename src/{bootsupport/modules/shellthread-1.6.2.tm => project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellthread-1.6.3.tm} (97%) rename src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/{tomlish-1.1.8.tm => tomlish-1.1.10.tm} (98%) rename src/project_layouts/custom/_project/{punk.project-0.1/src/bootsupport/modules/punk-0.1.1.tm => punk.shell-0.1/src/bootsupport/modules/punk-0.2.0.tm} (94%) rename src/{vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm => project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.3.tm} (99%) rename src/{bootsupport/modules/punk/ns-0.1.0.tm => project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.1.tm} (99%) rename src/{bootsupport/modules/punk/packagepreference-0.1.0.tm => project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.1.tm} (98%) rename src/project_layouts/custom/_project/{punk.project-0.1/src/bootsupport/modules/punk/path-0.2.1.tm => punk.shell-0.1/src/bootsupport/modules/punk/path-0.2.2.tm} (93%) rename src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/{shellfilter-0.2.3.tm => shellfilter-0.2.4.tm} (99%) rename src/project_layouts/custom/_project/{punk.project-0.1/src/bootsupport/modules/shellthread-1.6.2.tm => punk.shell-0.1/src/bootsupport/modules/shellthread-1.6.3.tm} (97%) rename src/{bootsupport/modules/tomlish-1.1.8.tm => project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/tomlish-1.1.10.tm} (98%) rename src/vfs/_vfscommon.vfs/modules/{punk-0.1.1.tm => punk-0.2.0.tm} (94%) rename src/{project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm => vfs/_vfscommon.vfs/modules/punk/args-0.2.3.tm} (99%) rename src/{project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm => vfs/_vfscommon.vfs/modules/punk/ns-0.1.1.tm} (99%) diff --git a/src/bootsupport/modules/punk-0.1.1.tm b/src/bootsupport/modules/punk-0.2.0.tm similarity index 94% rename from src/bootsupport/modules/punk-0.1.1.tm rename to src/bootsupport/modules/punk-0.2.0.tm index 8fa2cac2..a8086722 100644 --- a/src/bootsupport/modules/punk-0.1.1.tm +++ b/src/bootsupport/modules/punk-0.2.0.tm @@ -8411,38 +8411,507 @@ namespace eval punk { } puts -nonewline stdout \n } - #return list of {chan chunk} elements - namespace eval argdoc { + #punk::help topic registry + #Each registered topic has: + # - a handler proc ::punk::helptopic:: taking a context dict plus any extra words, + # returning the topic's help content as a list of {channel text} chunks + # - a punk::args definition with id ::punk::helptopic:: so that 'i help ' shows documented usage + #Registering a topic (re)generates the ::punk::help and ::punk::help_chunks punk::args definitions, + #so the documented topic choices always match the registry. + #The 'overview' handler is not a registered topic - it is what a plain 'help' displays. + #Unregistered topic words fall through to basic command-info lookup (see ::punk::help_chunks). + namespace eval helptopic { + variable topics [dict create] + + tcl::namespace::import ::punk::ansi::a ::punk::ansi::a+ + + proc register {topic aliases summary} { + variable topics + if {![llength [info commands [namespace current]::$topic]]} { + error "punk::helptopic::register - no handler proc '[namespace current]::$topic' exists for topic '$topic'" + } + dict set topics $topic [dict create aliases $aliases summary $summary] + define_docs + return + } + + #return the canonical topic name for a topic word or alias - empty string if not a registered topic + proc resolve {word} { + variable topics + dict for {topic tinfo} $topics { + if {$word eq $topic || $word in [dict get $tinfo aliases]} { + return $topic + } + } + return "" + } + + #standard command-info table as used by the help overview blocks + proc table_block {frametype title rows {minwidth 80}} { + set t [textblock::class::table new -minwidth $minwidth -show_seps 0] + $t configure -frametype $frametype + foreach row $rows { + $t add_row $row + } + $t configure_column 0 -minwidth [expr {[$t column_datawidth 0] + 2}] + $t configure_column 1 -minwidth [expr {[$t column_datawidth 1] + 1}] + $t configure -title $title + set text [$t print] + $t destroy + return $text + } + + #(re)generate the punk::args definitions for ::punk::help and ::punk::help_chunks from the registry + #so that 'i help' shows a documented topic table matching the registered topics. + proc define_docs {} { + variable topics + set choices [list] + set choiceinfo [dict create] + set choicelabels [dict create] + dict for {topic tinfo} $topics { + foreach name [list $topic {*}[dict get $tinfo aliases]] { + lappend choices $name + dict set choiceinfo $name [list [list doctype punkargs] [list subhelp [namespace current]::$topic]] + dict set choicelabels $name [dict get $tinfo summary] + } + } + set basehelp {Help system for the punk shell. + With no arguments - an overview of some key shell commands is displayed. + When the first argument is a recognised topic - help for that topic is displayed. + ('help topics' lists the available topics) + Anything else is treated as a command name - basic command info (type and + synopsis) is shown for a resolvable command, or the resolved path for an + external executable.} + set topichelp {Help topic, or command words for basic command info. (topics must match exactly - no prefix matching)} + set specs [list] + lappend specs ::punk::help help "Punk shell help system." "" + lappend specs ::punk::help_chunks punk::help_chunks "Punk shell help system - content as {channel text} chunks." "\n\nhelp_chunks returns the help content as a list of {channel text} chunks rather than emitting it." + foreach {id name summary extra} $specs { + set def "" + append def "@id -id $id" \n + append def "@cmd -name $name -summary \"$summary\" -help \"$basehelp$extra\"" \n + append def "@leaders -min 0 -max -1" \n + append def "topic -optional 1 -multiple 1 -type string -choiceprefix 0 -choicerestricted 0 -choices {$choices} -choiceinfo {$choiceinfo} -choicelabels {$choicelabels} -help \"$topichelp\"" \n + append def "@values -min 0 -max 0" + if {[punk::args::id_exists $id]} { + #quiet undefine - redefinition on registry change is expected, not noteworthy + punk::args::undefine $id 1 + } + punk::args::define $def + } + } + + #The no-topic overview of key shell commands (what a plain 'help' displays) + proc overview {context args} { + set frametype [dict get $context frametype] + set I [dict get $context I] + set NI [dict get $context NI] + set chunks [list] + + set title "[a+ brightgreen] Filesystem navigation: " + set cmdinfo [list] + lappend cmdinfo [list ./ "?${I}glob${NI}?" "view/change dir, list dirs."] + lappend cmdinfo [list .// "?${I}glob${NI}?" "view/change dir, list dirs and files"] + lappend cmdinfo [list ../ "?${I}path${NI}" "go up one dir, then to path if given"] + 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)"] + lappend chunks [list stdout [table_block $frametype $title $cmdinfo]\n] + + 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 "newns" "${I}ns${NI}" "make child namespace and switch to it"] + lappend chunks [list stdout [table_block $frametype $title $cmdinfo]\n] + + set title "[a+ brightgreen] Command help: " + set cmdinfo [list] + lappend cmdinfo [list i "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show usage for a command or ensemble subcommand"] + lappend cmdinfo [list s "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show synopsis for a command or ensemble subcommand"] + lappend cmdinfo [list eg "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show example from manpage"] + lappend cmdinfo [list corp "${I}proc${NI}" "View proc body and arguments with basic highlighting"] + lappend chunks [list stdout [table_block $frametype $title $cmdinfo]\n] + + set title "[a+ brightgreen] Miscellaneous: " + #todo - load from source code annotation? + set cmdinfo [list] + lappend cmdinfo [list dev "?${I}subcommand${NI}?" "(ensemble command to make new projects/modules and\n to generate docs)"] + lappend cmdinfo [list a? "?${I}subcommand${NI}...?" "view ANSI colours\n e.g a? web\n or individual code samples/diagnostics\n e.g a? red bold\n e.g a? underline web-orange Term-purple3"] + lappend cmdinfo [list a+ "?${I}colourcode${NI}...?" "Return ANSI codes\n e.g puts \"\[a+ purple\]purple\[a+ Green\]purple on green\[a\]\"\n [a+ purple]purple[a+ Green]purple on green[a] "] + lappend cmdinfo [list a "?${I}colourcode${NI}...?" "Return ANSI codes (with leading reset)\n e.g puts \"\[a+ purple\]purple\[a Green\]normal on green\[a\]\"\n [a+ purple]purple[a Green]normal on green[a] "] + lappend chunks [list stdout [table_block $frametype $title $cmdinfo]] + + return $chunks + } + punk::args::define { - @id -id ::punk::help_chunks - @cmd -name "punk::help_chunks"\ - -summary\ - ""\ - -help\ - "" - @opts - -- -type none - @values -min 0 -max -1 - arg -type any -optional 1 -multiple 1 + @id -id ::punk::helptopic::topics + @cmd -name "help topics" -summary "List help topics." -help "Show the table of topics known to the help system, including registered aliases for each topic." + @values -min 0 -max 0 + } + proc topics {context args} { + variable topics + set frametype [dict get $context frametype] + set t [textblock::class::table new -show_seps 0] + $t configure -frametype $frametype + $t add_column -headers [list "Topic"] + $t add_column + dict for {topic tinfo} $topics { + $t add_row [list [join [list $topic {*}[dict get $tinfo aliases]] |] [dict get $tinfo summary]] + } + $t add_row [list "*" "Look up as a command or external executable"] + $t configure_column 0 -minwidth [expr {[$t column_datawidth 0] + 4}] + set text \n[$t print] + $t destroy + return [list [list stdout $text]] + } + + punk::args::define { + @id -id ::punk::helptopic::tcl + @cmd -name "help tcl" -summary "Tcl version warnings." -help "Show the running Tcl patchlevel and build-info, with warnings for known Tcl bugs affecting this interpreter (as detected by the punk::lib::check::has_tclbug_* checks)." + @values -min 0 -max 0 + } + proc tcl {context args} { + set chunks [list] + set warningblock "" + set text "Tcl Patchlevel: [info patchlevel]" + catch { + append text \n "Tcl build-info: [::tcl::build-info]" + } + #generate warningblocks for each triggered Tcl bug in namespace ::punk::lib::check + set bugcheck_procs [info procs ::punk::lib::check::has_tclbug*] + foreach bp $bugcheck_procs { + set buginfo [$bp] + if {[dict get $buginfo bug]} { + set level unknown + if {[dict exists $buginfo level]} { + set level [dict get $buginfo level] + } + switch -- $level { + minor {set highlight [punk::ansi::a+ cyan]} + medium {set highlight [punk::ansi::a+ yellow]} + major {set highlight [punk::ansi::a+ red bold]} + default {set highlight ""} + } + append warningblock \n $highlight "warning level: $level $bp triggered." + if {[dict exists $buginfo description]} { + set indent " " + append warningblock \n "[punk::lib::indent [dict get $buginfo description] $indent]" + } + if {[dict exists $buginfo bugref] && [dict get $buginfo bugref] ne ""} { + set bugref [dict get $buginfo bugref] + append warningblock \n "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/$bugref]" + } + append warningblock [a] + } + } + + if {[catch {lsearch -stride 2 {a b} b}]} { + #has_tclbug_lsearch_strideallinline will have reported bug false because it couldn't test it. + set indent " " + append warningblock \n "[a+ web-red]warning: lsearch does not seem to support -stride option" \n + append warningblock "${indent}(Consider upgrading to a late release of tcl 8.6 or tcl 9+ )" \n + append warningblock [a] + } + lappend chunks [list stdout $text] + lappend chunks [list stderr $warningblock] + return $chunks + } + + punk::args::define { + @id -id ::punk::helptopic::env + @cmd -name "help env" -summary "punkshell environment vars." -help "Show punk-related and other relevant environment variables with their current values." + @values -min 0 -max 0 + } + proc env {context args} { + if {[catch {package require punk::config} errM]} { + return [list [list stderr "help env: punk::config package not available - no environment variable info ($errM)\n"]] + } + if {![info exists ::punk::config::punk_env_vars_config] || ![info exists ::punk::config::other_env_vars_config]} { + #punk::config::init has side effects (config dir/file creation) - don't trigger it just for help + return [list [list stderr "help env: punk::config not initialised - no environment variable info\n"]] + } + set frametype [dict get $context frametype] + set linesep [string repeat - 76] + set chunks [list] + set text "" + #todo - move to punk::config? + upvar ::punk::config::punk_env_vars_config punkenv_config + upvar ::punk::config::other_env_vars_config otherenv_config + + set known_punk [dict keys $punkenv_config] + set known_other [dict keys $otherenv_config] + append text \n + set usetable 1 + if {$usetable} { + set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] + $t configure -frametype $frametype + if {"windows" eq $::tcl_platform(platform)} { + #If any env vars have been set to empty string - this is considered a deletion of the variable on windows. + #The Tcl ::env array is linked to the underlying process view of the environment + #- but info exists ::env(var) can misreport as true if it has been deleted by setting to empty string rather than using unset. + #an 'array get' will resynchronise. + #Even if an env variable didn't exist before - setting it to empty string can get it to this inconsistent state. + array get ::env + } + #do an array read on ::env + foreach {v vinfo} $punkenv_config { + if {[info exists ::env($v)]} { + set c2 [set ::env($v)] + } else { + set c2 "(NOT SET)" + } + set help "" + if {[dict exists $vinfo help]} { + set help [dict get $vinfo help] + } + $t add_row [list $v $c2 $help] + } + $t configure_column 0 -headers [list "Punk environment vars"] + $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} + + set punktable [$t print] + $t destroy + + set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] + $t configure -frametype $frametype + foreach {v vinfo} $otherenv_config { + if {[info exists ::env($v)]} { + set env_val [set ::env($v)] + if {[string match "*_TM_PATH" $v]} { + set entries [split $env_val $::tcl_platform(pathSeparator)] + set c2 [join $entries \n] + } else { + set c2 $::env($v) + } + } else { + set c2 "(NOT SET)" + } + $t add_row [list $v $c2] + } + $t configure_column 0 -headers [list "Other environment vars"] + $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} + + set othertable [$t print] + $t destroy + #append text [textblock::join -- $punktable " " $othertable]\n + append text $punktable\n$othertable\n + } else { + + append text $linesep\n + append text "punk environment vars:\n" + append text $linesep\n + set col1 [string repeat " " 25] + set col2 [string repeat " " 50] + foreach v $known_punk { + set c1 [overtype::left $col1 $v] + if {[info exists ::env($v)]} { + set c2 [overtype::left $col2 [set ::env($v)]] + } else { + set c2 [overtype::right $col2 "(NOT SET)"] + } + append text "$c1 $c2\n" + } + append text $linesep\n + } + + lappend chunks [list stdout $text] + return $chunks + } + + punk::args::define { + @id -id ::punk::helptopic::console + @cmd -name "help console" -summary "Console behaviour tests and warnings." -help "Run some console/terminal behaviour tests (control string hiding, grapheme cluster support, cursor position query timing) and report warnings. Requires a responsive interactive console." + @values -min 0 -max 0 + } + proc console {context args} { + set chunks [list] + set warningblock "" + set term_env_vars {TERM TERM_PROGRAM TERM_PROGRAM_VERSION COLORTERM} + set term_dict [dict create] + foreach e $term_env_vars { + if {[info exists ::env($e)]} { + dict set term_dict $e [set ::env($e)] + } else { + dict set term_dict $e "(NOT SET)" + } + } + set text "Terminal environment variables:\n" + append text [punk::lib::showdict $term_dict] \n + lappend chunks [list stdout $text] + set text "" + set indent [string repeat " " [string length "WARNING: "]] + + 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 { + + if {![catch {punk::console::class_info} console_class_info]} { + set text "Terminal class info (from device secondary attributes query to terminal):\n" + append text [punk::lib::showdict $console_class_info] \n + } else { + set text "Unable to query terminal class info - err:$console_class_info\n" + } + lappend chunks [list stdout $text] + + 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" + } + } + 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" + } + + 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" + } + + + 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 posn [punk::console::get_cursor_pos] ;#warmup call - and test if works + if {$posn eq ""} { + append warningblock \n "WARNING: terminal doesn't respond to cursor position query - may cause display bugs in some cases." + } else { + set timeresult [timerate {set cpos [punk::console::get_cursor_pos]}] + lassign [split $cpos {;}] row col + if {![string is integer -strict $row] || ![string is integer -strict $col]} { + append warningblock \n "WARNING: terminal returns non-integer values for cursor position query - may cause display bugs in some cases. got row:'$row' col:'$col'" + } else { + set micros [lindex $timeresult 0] + if {$micros > 2000} { + append warningblock \n "WARNING: terminal cursor position query is very slow ($micros microseconds - expect < 2000us )" + append warningblock \n $indent "- may cause display lag/bugs in some cases." + } else { + if {$micros > 1000} { + set text "\n[a+ yellow]Terminal cursor position query test passed." + append text \n $indent "Response time: ${micros} microseconds (OK, good would be <= 1000us).[a]" + + } else { + set text "[a+ green]Terminal cursor position query test passed." + append text \n $indent "Response time: ${micros} microseconds (GOOD).[a]" + } + lappend chunks [list stdout $text] + } + } + } + + + if {![string length $warningblock]} { + set text "[a+ green]No terminal warnings[a]\n" + lappend chunks [list stdout $text] + } else { + set mode [punk::console::mode] + if {$mode eq "line"} { + append warningblock \n "Terminal appears to be in line mode. Consider switching to raw mode and re-testing (command: punk::console::mode raw)." + } + } + puts stdout [punk::ansi::move_back 200] ;#hack for some horizontal position bugs where the above tests can leave the cursor in the wrong place for the next output. + #200 is arbitrary large number to move back enough to get to start of line. + } + lappend chunks [list stderr $warningblock] + return $chunks } + + register topics {help} "List help topics" + register tcl {} "Tcl version warnings" + register env {environment} "punkshell environment vars" + register console {term terminal} "Some console behaviour tests and warnings" } + + #return list of {chan chunk} elements proc help_chunks {args} { - set argd [punk::args::parse $args withid ::punk::help_chunks] + set argd [punk::args::parse $args withid ::punk::help] lassign [dict values $argd] leaders opts values received - if {[dict exists $values arg]} { - set topicparts [dict get $values arg] + if {[dict exists $leaders topic]} { + set topicparts [dict get $leaders topic] } else { set topicparts [list ""] } - #set topic [lindex $args end] - #set argopts [lrange $args 0 end-1] - set chunks [list] - set linesep [string repeat - 76] - - set warningblock "" set I [punk::ansi::a+ italic] set NI [punk::ansi::a+ noitalic] @@ -8471,6 +8940,8 @@ namespace eval punk { } + set context [dict create cols $cols rows $rows frametype $frametype I $I NI $NI] + # ------------------------------------------------------- set logoblock "" if {[catch { @@ -8483,473 +8954,54 @@ namespace eval punk { set title "[a+ brightgreen] Help System: " set cmdinfo [list] lappend cmdinfo [list help "?${I}topic${NI}?" "This help.\nTo see available subitems type:\nhelp topics\n\nFor an unrecognised ${I}topic${NI}\nhelp will look for basic\ninfo for it as a command.\n"] - set t [textblock::class::table new -minwidth 51 -show_seps 0] - $t configure -frametype $frametype - foreach row $cmdinfo { - $t add_row $row - } - set width_0 [$t column_datawidth 0] - $t configure_column 0 -minwidth [expr {$width_0 + 2}] - set width_1 [$t column_datawidth 1] - $t configure_column 1 -minwidth [expr {$width_1 + 1}] - $t configure -title $title - set text [$t print] + set text [helptopic::table_block $frametype $title $cmdinfo 51] set introblock [textblock::join -- $logoblock $text] lappend chunks [list stdout $introblock\n] # ------------------------------------------------------- - switch -- [lindex $topicparts 0] { - "" { - - # ------------------------------------------------------- - set title "[a+ brightgreen] Filesystem navigation: " - set cmdinfo [list] - lappend cmdinfo [list ./ "?${I}glob${NI}?" "view/change dir, list dirs."] - lappend cmdinfo [list .// "?${I}glob${NI}?" "view/change dir, list dirs and files"] - lappend cmdinfo [list ../ "?${I}path${NI}" "go up one dir, then to path if given"] - 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] - $t configure -frametype $frametype - foreach row $cmdinfo { - $t add_row $row - } - set width_0 [$t column_datawidth 0] - $t configure_column 0 -minwidth [expr {$width_0 + 2}] - set width_1 [$t column_datawidth 1] - $t configure_column 1 -minwidth [expr {$width_1 + 1}] - $t configure -title $title - - set text "" - append text [$t print] - lappend chunks [list stdout $text\n] - # ------------------------------------------------------- - - - # ------------------------------------------------------- - 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 "newns" "${I}ns${NI}" "make child namespace and switch to it"] - set t [textblock::class::table new -minwidth 80 -show_seps 0] - $t configure -frametype $frametype - foreach row $cmdinfo { - $t add_row $row - } - set width_0 [$t column_datawidth 0] - $t configure_column 0 -minwidth [expr {$width_0 + 2}] - set width_1 [$t column_datawidth 1] - $t configure_column 1 -minwidth [expr {$width_1 + 1}] - $t configure -title $title - - set text "" - append text [$t print] - lappend chunks [list stdout $text\n] - # ------------------------------------------------------- - - # ------------------------------------------------------- - set title "[a+ brightgreen] Command help: " - set cmdinfo [list] - lappend cmdinfo [list i "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show usage for a command or ensemble subcommand"] - lappend cmdinfo [list s "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show synopsis for a command or ensemble subcommand"] - lappend cmdinfo [list eg "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show example from manpage"] - lappend cmdinfo [list corp "${I}proc${NI}" "View proc body and arguments with basic highlighting"] - set t [textblock::class::table new -minwidth 80 -show_seps 0] - $t configure -frametype $frametype - foreach row $cmdinfo { - $t add_row $row - } - set width_0 [$t column_datawidth 0] - $t configure_column 0 -minwidth [expr {$width_0 + 2}] - set width_1 [$t column_datawidth 1] - $t configure_column 1 -minwidth [expr {$width_1 + 1}] - $t configure -title $title - - set text "" - append text [$t print] - lappend chunks [list stdout $text\n] - # ------------------------------------------------------- - - - set title "[a+ brightgreen] Miscellaneous: " - #todo - load from source code annotation? - set cmdinfo [list] - lappend cmdinfo [list dev "?${I}subcommand${NI}?" "(ensemble command to make new projects/modules and\n to generate docs)"] - lappend cmdinfo [list a? "?${I}subcommand${NI}...?" "view ANSI colours\n e.g a? web\n or individual code samples/diagnostics\n e.g a? red bold\n e.g a? underline web-orange Term-purple3"] - lappend cmdinfo [list a+ "?${I}colourcode${NI}...?" "Return ANSI codes\n e.g puts \"\[a+ purple\]purple\[a+ Green\]purple on green\[a\]\"\n [a+ purple]purple[a+ Green]purple on green[a] "] - lappend cmdinfo [list a "?${I}colourcode${NI}...?" "Return ANSI codes (with leading reset)\n e.g puts \"\[a+ purple\]purple\[a Green\]normal on green\[a\]\"\n [a+ purple]purple[a Green]normal on green[a] "] - - set t [textblock::class::table new -minwidth 80 -show_seps 0] - $t configure -frametype $frametype - foreach row $cmdinfo { - $t add_row $row - } - set width_0 [$t column_datawidth 0] - $t configure_column 0 -minwidth [expr {$width_0 + 2}] - set width_1 [$t column_datawidth 1] - $t configure_column 1 -minwidth [expr {$width_1 + 1}] - $t configure -title $title - - set text "" - append text [$t print] - lappend chunks [list stdout $text] - # ------------------------------------------------------- - - } - tcl { - set text "Tcl Patchlevel: [info patchlevel]" - catch { - append text \n "Tcl build-info: [::tcl::build-info]" - } - #generate warningblocks for each triggered Tcl bug in namespace ::punk::lib::check - set bugcheck_procs [info procs ::punk::lib::check::has_tclbug*] - foreach bp $bugcheck_procs { - set buginfo [$bp] - if {[dict get $buginfo bug]} { - set level unknown - if {[dict exists $buginfo level]} { - set level [dict get $buginfo level] - } - switch -- $level { - minor {set highlight [punk::ansi::a+ cyan]} - medium {set highlight [punk::ansi::a+ yellow]} - major {set highlight [punk::ansi::a+ red bold]} - default {set highlight ""} - } - append warningblock \n $highlight "warning level: $level $bp triggered." - if {[dict exists $buginfo description]} { - set indent " " - append warningblock \n "[punk::lib::indent [dict get $buginfo description] $indent]" - } - if {[dict exists $buginfo bugref] && [dict get $buginfo bugref] ne ""} { - set bugref [dict get $buginfo bugref] - append warningblock \n "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/$bugref]" - } - append warningblock [a] - } - } - - if {[catch {lsearch -stride 2 {a b} b}]} { - #has_tclbug_lsearch_strideallinline will have reported bug false because it couldn't test it. - set indent " " - append warningblock \n "[a+ web-red]warning: lsearch does not seem to support -stride option" \n - append warningblock "${indent}(Consider upgrading to a late release of tcl 8.6 or tcl 9+ )" \n - append warningblock [a] - } - lappend chunks [list stdout $text] - } - env - environment { - set text "" - #todo - move to punk::config? - upvar ::punk::config::punk_env_vars_config punkenv_config - upvar ::punk::config::other_env_vars_config otherenv_config - - set known_punk [dict keys $punkenv_config] - set known_other [dict keys $otherenv_config] - append text \n - set usetable 1 - if {$usetable} { - set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] - $t configure -frametype $frametype - if {"windows" eq $::tcl_platform(platform)} { - #If any env vars have been set to empty string - this is considered a deletion of the variable on windows. - #The Tcl ::env array is linked to the underlying process view of the environment - #- but info exists ::env(var) can misreport as true if it has been deleted by setting to empty string rather than using unset. - #an 'array get' will resynchronise. - #Even if an env variable didn't exist before - setting it to empty string can get it to this inconsistent state. - array get ::env - } - #do an array read on ::env - foreach {v vinfo} $punkenv_config { - if {[info exists ::env($v)]} { - set c2 [set ::env($v)] - } else { - set c2 "(NOT SET)" - } - set help "" - if {[dict exists $vinfo help]} { - set help [dict get $vinfo help] - } - $t add_row [list $v $c2 $help] - } - $t configure_column 0 -headers [list "Punk environment vars"] - $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} - - set punktable [$t print] - $t destroy - - set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] - $t configure -frametype $frametype - foreach {v vinfo} $otherenv_config { - if {[info exists ::env($v)]} { - set env_val [set ::env($v)] - if {[string match "*_TM_PATH" $v]} { - set entries [split $env_val $::tcl_platform(pathSeparator)] - set c2 [join $entries \n] - } else { - set c2 $::env($v) - } - } else { - set c2 "(NOT SET)" - } - $t add_row [list $v $c2] - } - $t configure_column 0 -headers [list "Other environment vars"] - $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} - - set othertable [$t print] - $t destroy - #append text [textblock::join -- $punktable " " $othertable]\n - append text $punktable\n$othertable\n + set word0 [lindex $topicparts 0] + set topic [helptopic::resolve $word0] + if {$word0 eq ""} { + #no topic supplied - overview of key shell commands + lappend chunks {*}[helptopic::overview $context {*}[lrange $topicparts 1 end]] + } elseif {$topic ne ""} { + lappend chunks {*}[helptopic::$topic $context {*}[lrange $topicparts 1 end]] + } else { + #not a registered topic - fall through to basic command info lookup + set text "" + set cinfo [uplevel 1 [list ::punk::ns::cmdwhich [lindex $topicparts 0]]] + set wtype [dict get $cinfo whichtype] + if {$wtype eq "notfound"} { + set externalinfo [auto_execok [lindex $topicparts 0]] + if {[string length $externalinfo]} { + set text "$topicparts" + append text \n "Base type: External command" + append text \n "$externalinfo [lrange $topicparts 1 end]" } else { - - append text $linesep\n - append text "punk environment vars:\n" - append text $linesep\n - set col1 [string repeat " " 25] - set col2 [string repeat " " 50] - foreach v $known_punk { - set c1 [overtype::left $col1 $v] - if {[info exists ::env($v)]} { - set c2 [overtype::left $col2 [set ::env($v)]] - } else { - set c2 [overtype::right $col2 "(NOT SET)"] - } - append text "$c1 $c2\n" - } - append text $linesep\n + set text "$topicparts\n" + append text "No matching internal or external command found" } - - lappend chunks [list stdout $text] - } - console - term - terminal { - set term_env_vars {TERM TERM_PROGRAM TERM_PROGRAM_VERSION COLORTERM} - set term_dict [dict create] - foreach e $term_env_vars { - if {[info exists ::env($e)]} { - dict set term_dict $e [set ::env($e)] - } else { - dict set term_dict $e "(NOT SET)" - } - } - set text "Terminal environment variables:\n" - append text [punk::lib::showdict $term_dict] \n - lappend chunks [list stdout $text] - set text "" - set indent [string repeat " " [string length "WARNING: "]] - - 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 { - - if {![catch {punk::console::class_info} console_class_info]} { - set text "Terminal class info (from device secondary attributes query to terminal):\n" - append text [punk::lib::showdict $console_class_info] \n - } else { - set text "Unable to query terminal class info - err:$console_class_info\n" - } - lappend chunks [list stdout $text] - - 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" - } - } - 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" - } - - 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" - } - - - 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 posn [punk::console::get_cursor_pos] ;#warmup call - and test if works - if {$posn eq ""} { - append warningblock \n "WARNING: terminal doesn't respond to cursor position query - may cause display bugs in some cases." - } else { - set timeresult [timerate {set cpos [punk::console::get_cursor_pos]}] - lassign [split $cpos {;}] row col - if {![string is integer -strict $row] || ![string is integer -strict $col]} { - append warningblock \n "WARNING: terminal returns non-integer values for cursor position query - may cause display bugs in some cases. got row:'$row' col:'$col'" - } else { - set micros [lindex $timeresult 0] - if {$micros > 2000} { - append warningblock \n "WARNING: terminal cursor position query is very slow ($micros microseconds - expect < 2000us )" - append warningblock \n $indent "- may cause display lag/bugs in some cases." - } else { - if {$micros > 1000} { - set text "\n[a+ yellow]Terminal cursor position query test passed." - append text \n $indent "Response time: ${micros} microseconds (OK, good would be <= 1000us).[a]" - - } else { - set text "[a+ green]Terminal cursor position query test passed." - append text \n $indent "Response time: ${micros} microseconds (GOOD).[a]" - } - lappend chunks [list stdout $text] - } - } - } - - - if {![string length $warningblock]} { - set text "[a+ green]No terminal warnings[a]\n" - lappend chunks [list stdout $text] + } else { + set text "[dict get $cinfo which] [lrange $topicparts 1 end]" + append text \n "Base type: $wtype" + set synopsis [uplevel 1 [list ::punk::ns::synopsis {*}$topicparts]] + set synshow "" + foreach sline [split $synopsis \n] { + if {[regexp {\s*#.*} $sline]} { + append synshow [punk::ansi::a+ bold term-darkgreen Term-white]$sline[punk::ansi::a] \n } else { - set mode [punk::console::mode] - if {$mode eq "line"} { - append warningblock \n "Terminal appears to be in line mode. Consider switching to raw mode and re-testing (command: punk::console::mode raw)." - } + append synshow $sline \n } - puts stdout [punk::ansi::move_back 200] ;#hack for some horizontal position bugs where the above tests can leave the cursor in the wrong place for the next output. - #200 is arbitrary large number to move back enough to get to start of line. - } - } - topics - help { - set text "" - set topics [dict create {*}{ - "topics|help" "List help topics" - "tcl" "Tcl version warnings" - "env|environment" "punkshell environment vars" - "console|terminal" "Some console behaviour tests and warnings" - "*" "Try to find help on the topic as a command or external executable" - }] - - set t [textblock::class::table new -show_seps 0] - $t configure -frametype $frametype - $t add_column -headers [list "Topic"] - $t add_column - foreach {k v} $topics { - $t add_row [list $k $v] } - set widest0 [$t column_datawidth 0] - $t configure_column 0 -minwidth [expr {$widest0 + 4}] - append text \n [$t print] - - lappend chunks [list stdout $text] - } - default { - set text "" - set cinfo [uplevel 1 [list ::punk::ns::cmdwhich [lindex $topicparts 0]]] - set wtype [dict get $cinfo whichtype] - if {$wtype eq "notfound"} { - set externalinfo [auto_execok [lindex $topicparts 0]] - if {[string length $externalinfo]} { - set text "$topicparts" - append text \n "Base type: External command" - append text \n "$externalinfo [lrange $topicparts 1 end]" - } else { - set text "$topicparts\n" - append text "No matching internal or external command found" - } - } else { - set text "[dict get $cinfo which] [lrange $topicparts 1 end]" - append text \n "Base type: $wtype" - set synopsis [uplevel 1 [list ::punk::ns::synopsis {*}$topicparts]] - set synshow "" - foreach sline [split $synopsis \n] { - if {[regexp {\s*#.*} $sline]} { - append synshow [punk::ansi::a+ bold term-darkgreen Term-white]$sline[punk::ansi::a] \n - } else { - append synshow $sline \n - } - } - if {[string index $synshow end] eq "\n"} { - set synshow [string range $synshow 0 end-1] - } - append text \n $synshow + if {[string index $synshow end] eq "\n"} { + set synshow [string range $synshow 0 end-1] } - lappend chunks [list stdout $text] + append text \n $synshow } + lappend chunks [list stdout $text] } - - - lappend chunks [list stderr $warningblock] return $chunks } proc mode {{raw_or_line query}} { @@ -9298,7 +9350,7 @@ punkcheck::cli set_alias punkcheck package provide punk [namespace eval punk { #FUNCTL variable version - set version 0.1.1 + set version 0.2.0 }] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm b/src/bootsupport/modules/punk/args-0.2.3.tm similarity index 99% rename from src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm rename to src/bootsupport/modules/punk/args-0.2.3.tm index 21ee1c6d..e8b2c3bf 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm +++ b/src/bootsupport/modules/punk/args-0.2.3.tm @@ -8,7 +8,7 @@ # (C) 2024 # # @@ Meta Begin -# Application punk::args 0.2.1 +# Application punk::args 0.2.3 # Meta platform tcl # Meta license # @@ Meta End @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_punk::args 0 0.2.1] +#[manpage_begin punkshell_module_punk::args 0 0.2.3] #[copyright "2024"] #[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] #[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] @@ -871,19 +871,46 @@ tcl::namespace::eval punk::args { -choicerestricted Whether values not specified in -choices or -choicegroups are allowed. Defaults to true. + When false, an input that matches no choice - including an + ambiguous prefix, a prefix of a -choiceprefixdenylist entry, + or a -choiceprefixreservelist word - is accepted unchanged as + an ordinary value (subject to -type validation) instead of + raising an error. This passthrough is the pattern for + arguments that mix a known choice set with free-form values + (e.g. a help topic word falling through to command lookup). -choiceprefix This specifies whether unique prefixes are able to be used instead of the complete string. This is calculated using tcl::prefix::match - and will display in the autogenerated usage output. Defaults to true. + A matching prefix is normalized: the parse result contains + the full choice string, never the typed prefix - so callers + switch on canonical choice values only. The usage display + highlights each choice's minimal accepted prefix (a choice + in -choiceprefixdenylist displays fully highlighted - the + whole word is required). -choiceprefixdenylist {} These choices should match exactly a choice entry in one of the settings -choices or -choicegroups. These will still be used in prefix calculation - but the full choice argument must be entered to select the choice. + A shorter prefix of a denied choice is an error when + -choicerestricted is true, and passes through as an ordinary + (non-choice) value when -choicerestricted is false - use this + to keep short words available for other purposes (e.g. with + 'help' denied, h/he/hel remain free-form values). -choiceprefixreservelist {} These choices are additional values used in prefix calculation. The values will not be added to the list of available choices. + A reserved word never matches: entered exactly it is an error + when -choicerestricted is true and passes through when false, + as do any shorter words it shadows into ambiguity. This gives + per-choice control of the minimum accepted prefix by reserving + phantom entries: e.g. -choices {environment} + -choiceprefixreservelist {en} means e/en do not match while + env, envi, ... environment all normalize to environment. + (To require a longer minimum, reserve each shorter form: + reserving {en env} raises the minimum to envi.) -choicegroups {} Generally this would be used instead of -choices to allow usage display of choices grouped by some name (or the empty @@ -6156,7 +6183,7 @@ tcl::namespace::eval punk::args { #puts stderr ">>>_get_dict_can_assign_value idx:$idx v:[lindex $values $idx] consumed:$alloc_count thistype:$thistype" set d [dict create consumed $alloc_count resultlist $resultlist typelist $newtypelist] } else { - puts stderr ">>>_get_dict_can_assign_value NOT alloc_ok: idx:$idx v:[lindex $values $idx] consumed:$alloc_count thistype:$thistype" + #puts stderr ">>>_get_dict_can_assign_value NOT alloc_ok: idx:$idx v:[lindex $values $idx] consumed:$alloc_count thistype:$thistype" set d [dict create consumed 0 resultlist {} typelist $thistype] } #puts ">>>> _get_dict_can_assign_value $d" @@ -9835,7 +9862,10 @@ tcl::namespace::eval punk::args { set argname [dict get $lookup_optset $fullflag] #idents should already have correct parsekey } else { - puts stderr "punk::args::get_dict unable to find $fullflag in $lookup_optset (parsekey:$parsekey) (value_group: $value_group)" + #adhoc option (allowed via "@opts -any|-arbitrary true") - not in lookup_optset. + #argstate/arg_checks were populated for it under its raw supplied name at scan time. + set argname $fullflag + #puts stderr "punk::args::get_dict unable to find $fullflag in $lookup_optset (parsekey:$parsekey) (value_group: $value_group)" } } else { if {[dict exists $lookup_optset $argname_or_ident]} { @@ -9850,7 +9880,15 @@ tcl::namespace::eval punk::args { set parsekey [string trimright [lindex [split $argname |] end] =] } } else { - puts stderr "punk::args::get_dict unable to find $argname_or_ident in $lookup_optset (value_group: $value_group)" + #adhoc option (allowed via "@opts -any|-arbitrary true") - not in lookup_optset. + #argstate/arg_checks were populated for it under its raw supplied name at scan time. + set argname $argname_or_ident + if {$pkoverride ne ""} { + set parsekey $pkoverride + } else { + set parsekey [string trimright [lindex [split $argname |] end] =] + } + #puts stderr "punk::args::get_dict unable to find $argname_or_ident in $lookup_optset (value_group: $value_group)" } } } else { @@ -12357,7 +12395,7 @@ package provide punk::args [tcl::namespace::eval punk::args { tcl::namespace::path {::punk::args::lib ::punk::args::system} variable pkg punk::args variable version - set version 0.2.1 + set version 0.2.3 }] return diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/bootsupport/modules/punk/ns-0.1.1.tm similarity index 99% rename from src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm rename to src/bootsupport/modules/punk/ns-0.1.1.tm index ad3cd57e..114d980b 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/bootsupport/modules/punk/ns-0.1.1.tm @@ -7,7 +7,7 @@ # (C) 2023 # # @@ Meta Begin -# Application punk::ns 0.1.0 +# Application punk::ns 0.1.1 # Meta platform tcl # Meta license # @@ Meta End @@ -4633,7 +4633,7 @@ y" {return quirkykeyscript} set vline [punk::args::ensemble_subcommands_definition -columns 2 $origin] set autoid "(autodef)$origin" - puts "ENSEMBLE auto def $autoid (generate_autodef)" + #puts "ENSEMBLE auto def $autoid (generate_autodef)" #A namespace can contain spaces, so an ensemble command can contain spaces. We must quote the -id value in the autodef set argdef [punk::lib::tstr -return string { @id -id "${$autoid}" @@ -4699,7 +4699,7 @@ y" {return quirkykeyscript} append argdef \n "@formdisplay -body {$tepamhelp}" punk::args::define $argdef } else { - puts "PROC auto def $autoid (generate_autodef)" + #puts "PROC auto def $autoid (generate_autodef)" #to handle procs like ":" (eg used by colin's bytecode based expr replacement) or other names of the form ":xyz" #we can't use 'info args :::' - tcl won't find it set ns [nsprefix $origin] @@ -5026,7 +5026,7 @@ y" {return quirkykeyscript} if {[punk::args::id_exists "$origin [lindex $args $i]"]} { set a [lindex $args $i] #review - tests? - puts stderr "cmd_traverse - skipping to documented subcommand '$origin $a'" + #puts stderr "cmd_traverse - skipping to documented subcommand '$origin $a'" #we can only seek beyond an undocumented subcommand level via a space delimited path, as we can make no assumption about the actual location of a subcommand relative to its parent #There could be a different command at for example "${origin}::$a" which is unrelated to the actual resolution path. set docid_exists 1 @@ -5120,7 +5120,7 @@ y" {return quirkykeyscript} lappend resolvedargs $q lpop queryargs_untested 0 lappend eparams $q - puts stderr "---> cmd_traverse ensembleparam $q ($lname)" + #puts stderr "---> cmd_traverse ensembleparam $q ($lname)" #puts stderr "arginfo: $arginfo" #puts stderr "---> eparams: $eparams" #puts stderr "---> existing args: $args" @@ -5304,7 +5304,7 @@ y" {return quirkykeyscript} } } #REVIEW!!! - puts stderr "cmd_traverse 10 $origin $resolvedargs $queryargs_untested $docid - review" + #puts stderr "cmd_traverse 10 $origin $resolvedargs $queryargs_untested $docid - review" return [list 10 $origin $resolvedargs $queryargs_untested $docid] } @@ -7591,6 +7591,6 @@ namespace eval ::punk::args::register { ## Ready package provide punk::ns [tcl::namespace::eval punk::ns { variable version - set version 0.1.0 + set version 0.1.1 }] return \ No newline at end of file diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm b/src/bootsupport/modules/punk/packagepreference-0.1.1.tm similarity index 98% rename from src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm rename to src/bootsupport/modules/punk/packagepreference-0.1.1.tm index 38b1f3fd..8ad1d774 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm +++ b/src/bootsupport/modules/punk/packagepreference-0.1.1.tm @@ -8,7 +8,7 @@ # (C) 2024 # # @@ Meta Begin -# Application punk::packagepreference 0.1.0 +# Application punk::packagepreference 0.1.1 # Meta platform tcl # Meta license # @@ Meta End @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_punk::packagepreference 0 0.1.0] +#[manpage_begin punkshell_module_punk::packagepreference 0 0.1.1] #[copyright "2024"] #[titledesc {punkshell package/module loading}] [comment {-- Name section and table of contents description --}] #[moddesc {package/module load}] [comment {-- Description at end of page heading --}] @@ -321,7 +321,9 @@ tcl::namespace::eval punk::packagepreference { if {[catch {thread::id} threadid]} { set threadid "unknown-threadid" } - puts stdout "punk::packagepreference overloaded 'package require': Loaded punk::args::moduledoc::$dp for package '$pkg' threadid: $threadid" + #notice goes to stderr: stdout must stay clean for script/exec contexts + #(e.g the punk executable's 'script' subcommand - machine-consumed output) + puts stderr "punk::packagepreference overloaded 'package require': Loaded punk::args::moduledoc::$dp for package '$pkg' threadid: $threadid" } } #--------------------------------------------------------------- @@ -487,7 +489,7 @@ namespace eval ::punk::args::register { package provide punk::packagepreference [tcl::namespace::eval punk::packagepreference { variable pkg punk::packagepreference variable version - set version 0.1.0 + set version 0.1.1 }] return diff --git a/src/bootsupport/modules/punk/path-0.2.1.tm b/src/bootsupport/modules/punk/path-0.2.2.tm similarity index 93% rename from src/bootsupport/modules/punk/path-0.2.1.tm rename to src/bootsupport/modules/punk/path-0.2.2.tm index 5ad6a0dc..0ae49215 100644 --- a/src/bootsupport/modules/punk/path-0.2.1.tm +++ b/src/bootsupport/modules/punk/path-0.2.2.tm @@ -7,7 +7,7 @@ # (C) 2023 # # @@ Meta Begin -# Application punk::path 0.2.1 +# Application punk::path 0.2.2 # Meta platform tcl # Meta license # @@ Meta End @@ -17,7 +17,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_punk::path 0 0.2.1] +#[manpage_begin punkshell_module_punk::path 0 0.2.2] #[copyright "2023"] #[titledesc {Filesystem path utilities}] [comment {-- Name section and table of contents description --}] #[moddesc {punk path filesystem utils}] [comment {-- Description at end of page heading --}] @@ -485,6 +485,87 @@ namespace eval punk::path { return relative } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::punk::path::scriptlib_resolve + @cmd -name "punk::path::scriptlib_resolve"\ + -summary\ + "Resolve a scriptlib script name to a path using the punk kit search policy"\ + -help\ + "Resolves a relative script name (the part after a 'lib:' prefix + in punk executable launch arguments) against the scriptlib + locations, in the same order the punk shell uses: + + 1. the kit vfs internal scriptlib (/app/scriptlib, + or /scriptlib for an unwrapped kit directory). + Internal scripts are deliberately NOT overridable by + external files (integrity and performance). + 2. /scriptlib - e.g /scriptlib for + an executable in /bin. + 3. /scriptlib. + + If the name's extension (lowercased) is not one of the known + scriptlib extensions (.tcl .py .pl .ps1 .sh), '.tcl' is + appended - only .tcl scripts may be named extensionlessly. + + Returns a dict with keys: + path - resolved absolute path, or empty string if not found + scriptname - the name searched for (extension applied) + candidates - the locations that were (or would be) checked, + for use in error messages. + Raises an error if name is not a relative path." + @leaders + name -type string -optional 0 -help\ + "relative script name, with or without a known extension + (any leading lib: prefix should already be stripped)" + }] + } + proc scriptlib_resolve {name} { + #shared resolution policy for the 'lib:' script prefix - used by the punk + #executable 'script' subcommand (app-punkscript); app-punkshell's shell + #subcommand encodes the same policy (todo: refactor it onto this proc). + if {[lindex [pathtype $name] 0] ne "relative"} { + error "punk::path::scriptlib_resolve name must be a relative path (got '$name')" + } + set known_extensions [list .tcl .py .pl .ps1 .sh] + if {[string tolower [file extension $name]] ni $known_extensions} { + #only .tcl scripts allowed to be called extensionlessly + set scriptname $name.tcl + } else { + set scriptname $name + } + set exepath [file dirname [file normalize [file join [info nameofexecutable] ___]]] ;#symlink resolve + set candidates [list] + #1) kit-internal scriptlib - not overridable externally + set has_zipfs_command [expr {[info commands ::tcl::zipfs::root] ne ""}] + set kit_base "" + if {$has_zipfs_command && [file exists [tcl::zipfs::root]]} { + set kit_base [tcl::zipfs::root] + } elseif {[file type $exepath] eq "directory"} { + set kit_base $exepath + } + set kit_libdir "" + if {$has_zipfs_command && $kit_base ne "" && [file exists $kit_base/app/scriptlib]} { + set kit_libdir $kit_base/app/scriptlib + } elseif {[file exists $exepath/scriptlib]} { + set kit_libdir $exepath/scriptlib + } + if {$kit_libdir ne ""} { + lappend candidates $kit_libdir/$scriptname + if {[file exists $kit_libdir/$scriptname]} { + return [dict create path $kit_libdir/$scriptname scriptname $scriptname candidates $candidates] + } + } + #2,3) external scriptlib folders relative to the executable location + set exedir [file dirname $exepath] + foreach dir [list [file join $exedir scriptlib] [file join [file dirname $exedir] scriptlib]] { + lappend candidates [file join $dir $scriptname] + if {[file isdirectory $dir] && [file exists [file join $dir $scriptname]]} { + return [dict create path [file join $dir $scriptname] scriptname $scriptname candidates $candidates] + } + } + return [dict create path "" scriptname $scriptname candidates $candidates] + } proc plain {str} { set str [string map "\\\\ /" $str] @@ -1598,12 +1679,19 @@ namespace eval punk::path::system { } + +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + #documentation-only PUNKARGS registration - discovered lazily if/when punk::args loads + lappend ::punk::args::register::NAMESPACES ::punk::path::argdoc +} + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready package provide punk::path [namespace eval punk::path { variable pkg punk::path variable version - set version 0.2.1 + set version 0.2.2 }] return diff --git a/src/bootsupport/modules/shellfilter-0.2.3.tm b/src/bootsupport/modules/shellfilter-0.2.4.tm similarity index 99% rename from src/bootsupport/modules/shellfilter-0.2.3.tm rename to src/bootsupport/modules/shellfilter-0.2.4.tm index 4f64e822..d060aced 100644 --- a/src/bootsupport/modules/shellfilter-0.2.3.tm +++ b/src/bootsupport/modules/shellfilter-0.2.4.tm @@ -2813,8 +2813,11 @@ namespace eval shellfilter { set syslog [dict get $opts -syslog] dict unset opts -syslog set runtag "shellfilter-run" - set tid [::shellfilter::log::open $runtag [list -syslog 127.0.0.1:514]] - #set tid [::shellfilter::log::open $runtag [list -syslog $syslog]] + #honor the -syslog option (default empty) - the previous hardcoded 127.0.0.1:514 was a + #debug leftover. With no -syslog and no -file the runtag log worker is a noop (no thread + #is created). Syslog remains supported when explicitly configured; see G-036 for the + #Tcl 9 console+udp worker wedge that the always-on syslog worker exposed on exit/quit. + set tid [::shellfilter::log::open $runtag [list -syslog $syslog]] log::info {::shellfilter::log::write $runtag " opts: $opts"} log::info {::shellfilter::log::write $runtag " commandlist:'$commandlist' listlen:$listlen strlen:[string length $commandlist]"} @@ -3827,5 +3830,5 @@ namespace eval shellfilter { package provide shellfilter [namespace eval shellfilter { variable version - set version 0.2.3 + set version 0.2.4 }] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellthread-1.6.2.tm b/src/bootsupport/modules/shellthread-1.6.3.tm similarity index 97% rename from src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellthread-1.6.2.tm rename to src/bootsupport/modules/shellthread-1.6.3.tm index 79d12149..cd0c83c6 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellthread-1.6.2.tm +++ b/src/bootsupport/modules/shellthread-1.6.3.tm @@ -788,8 +788,12 @@ namespace eval shellthread::manager { foreach workertid $subscriberless_workers { if {$workertid ni $shuttingdown_workers} { if {$workertid ni $free_threads && $workertid ne "noop"} { - #JMN - thread::send $workertid {set ::shellthread::worker::settings $::shellthread::worker::settings_defaults} + #Must be async: unsubscribe is on the exit/quit teardown path and a worker whose + #event loop has stopped servicing events (G-036: Tcl 9 console+udp worker wedge) + #would block a synchronous send forever, freezing the shell. Async is safe - + #sends to a thread are processed FIFO, so a later reuse via new_worker sees the + #settings reset applied before anything it sends. + thread::send -async $workertid {set ::shellthread::worker::settings $::shellthread::worker::settings_defaults} #todo - log freeing up of thread lappend free_threads $workertid } @@ -812,7 +816,10 @@ namespace eval shellthread::manager { } proc get_tag_config {tag} { - #review + #review - bare synchronous thread::send: blocks forever if the worker's event loop is + #wedged (G-036 hazard class). Reached from new_worker when a tag already has a live + #worker. Needs a result so can't simply go async - convert to async + vwait-with-timeout + #if this path shows up in a hang. variable workers if {![dict exists $workers $tag]} { error "shellthread::manager::get_tag_config error no existing tag $tag" @@ -858,10 +865,13 @@ namespace eval shellthread::manager { set timedout 1 break } else { - after cancel $timeout_timer + #Do not cancel the timeout timer until all awaited workers have responded - + #cancelling on the first response left later vwait iterations unbounded, so a + #wedged worker (G-036) after a healthy one hung shutdown forever. lappend ended $::shellthread::waitfor } } + after cancel $timeout_timer } set free_threads [list] return [dict create existed $waiting_for ended $ended timedout $timedout allthreads [thread::names]] @@ -963,7 +973,7 @@ namespace eval shellthread::manager { package provide shellthread [namespace eval shellthread { variable version - set version 1.6.2 + set version 1.6.3 }] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/tomlish-1.1.8.tm b/src/bootsupport/modules/tomlish-1.1.10.tm similarity index 98% rename from src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/tomlish-1.1.8.tm rename to src/bootsupport/modules/tomlish-1.1.10.tm index e1be4767..68ac58f8 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/tomlish-1.1.8.tm +++ b/src/bootsupport/modules/tomlish-1.1.10.tm @@ -7,7 +7,7 @@ # (C) 2024 # # @@ Meta Begin -# Application tomlish 1.1.8 +# Application tomlish 1.1.10 # Meta platform tcl # Meta license # @@ Meta End @@ -17,7 +17,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin tomlish_module_tomlish 0 1.1.8] +#[manpage_begin tomlish_module_tomlish 0 1.1.10] #[copyright "2024"] #[titledesc {tomlish toml parser}] [comment {-- Name section and table of contents description --}] #[moddesc {tomlish}] [comment {-- Description at end of page heading --}] @@ -385,6 +385,45 @@ namespace eval tomlish { } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::tomlish::to_dict + @cmd -name "tomlish::to_dict"\ + -summary\ + "Convert a tomlish structure to a Tcl dict with typed leaf values"\ + -help\ + "Converts tomlish (the tagged-list representation produced + by tomlish::from_toml) to a Tcl dict datastructure. + + Toml tables map to nested dict keys. Each leaf value is a + two-element dict of the form {type value } + where is a toml/tomlish type such as INT, FLOAT, + BOOL, STRING, LITERAL, MULTISTRING, MULTILITERAL, DATETIME + or ARRAY (an ARRAY value is a list of typed elements). + Escape sequences in quoted strings are substituted during + this conversion. + + Whitespace and comments are not represented in the result, + so a dict alone cannot round-trip formatting - use + tomlish::update_tomlish_from_dict to write dict values back + into an existing tomlish structure when preservation + matters. + + Toml validity rules that require whole-document knowledge + (e.g 'You cannot define any key or table more than once') + are enforced here and raise errors. + + Returns the dict, or with returnextra true a dict with keys + 'datastructure' (the converted dict) and 'tablenames_info' + (per-tablename creation/definition metadata)." + @leaders + tomlish -type list -optional 0 -help\ + "tomlish tagged list (e.g from tomlish::from_toml)" + returnextra -type boolean -optional 1 -default 0 -help\ + "when true, return a dict of keys 'datastructure' and + 'tablenames_info' instead of the datastructure alone" + }] + } proc to_dict {tomlish {returnextra 0}} { tomlish::dict::from_tomlish $tomlish $returnextra } @@ -708,6 +747,31 @@ namespace eval tomlish { } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::tomlish::from_dict + @cmd -name "tomlish::from_dict"\ + -summary\ + "Convert a dict with typed leaf values to a tomlish structure"\ + -help\ + "Converts a Tcl dict whose leaf values are typed + ({type value } - the form produced by + tomlish::to_dict) into a new tomlish tagged-list structure, + which tomlish::to_toml can serialise to toml text. + + The dict must be a full typed representation - plain + untyped leaf values are not accepted. As a dict carries no + whitespace/comment information, the generated tomlish (and + any toml produced from it) uses generated formatting; to + preserve the formatting of an existing document, write + values back with tomlish::update_tomlish_from_dict instead. + + Returns the tomlish list." + @leaders + d -type dict -optional 0 -help\ + "dict with typed leaf values (e.g from tomlish::to_dict)" + }] + } proc from_dict {d} { #consider: # t1={a=1,b=2} @@ -906,6 +970,33 @@ namespace eval tomlish { # For this reason, we also do absolutely no line-ending transformations based on platform. # All line-endings are maintained as is, and even a file with mixed lf crlf line-endings will be correctly interpreted and can be 'roundtripped' + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::tomlish::from_toml + @cmd -name "tomlish::from_toml"\ + -summary\ + "Parse toml text into a tomlish tagged-list structure"\ + -help\ + "Parses toml source text into 'tomlish' - the intermediate + tagged-list representation used by the tomlish package. + + tomlish is whitespace and comment preserving: serialising + the result with tomlish::to_toml reproduces the input byte + for byte (lossless round-trip). No escape sequences in + quoted strings are processed at this stage and no + line-ending transformations are performed - that occurs in + datastructure conversions such as tomlish::to_dict. + + Returns the tomlish list: first element is the tag TOMLISH, + remaining elements are tagged records such as TABLE, + TABLEARRAY, DOTTEDKEY, WS, COMMENT, NEWLINE. + Raises an error for invalid toml." + @values -min 1 -max -1 + toml -type string -optional 0 -multiple 1 -help\ + "toml source text. Multiple values are joined with newline + characters before parsing." + }] + } proc from_toml {args} { namespace upvar ::tomlish::parse s s @@ -1764,6 +1855,34 @@ namespace eval tomlish { # updating from a subset dict (reduces processing - and more flexible to supply only paths to leaves requiring update?) # #todo - allow adding extra leaves e.g keys in tables,tablearrays, itables, arrays + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::tomlish::update_tomlish_from_dict + @cmd -name "tomlish::update_tomlish_from_dict"\ + -summary\ + "Update leaf values in a tomlish structure from a typed dict, preserving formatting"\ + -help\ + "Merges values from dict d into an existing tomlish + structure and returns the updated tomlish, in which + whitespace, comments and key ordering are preserved. + + This is the formatting-preserving write path: parse a + document with tomlish::from_toml, convert with + tomlish::to_dict, modify values in the dict, apply them + with this command, then serialise with tomlish::to_toml. + + d must be a full typed representation of the datastructure + (as produced by tomlish::to_dict). The initial + implementation updates leaf values only - adding or pruning + keys/branches is not yet supported." + @leaders + tomlish -type list -optional 0 -help\ + "existing tomlish tagged list (e.g from tomlish::from_toml)" + d -type dict -optional 0 -help\ + "full typed-dict representation carrying the updated leaf + values" + }] + } proc update_tomlish_from_dict {tomlish d} { set returnextra true #validate supplied tomlish and keep tablenames_info (review - validate structure only - allow invalid values to be overwritten from dict?) @@ -2441,6 +2560,34 @@ namespace eval tomlish::encode { #fish toml from tomlish #(encode tomlish as toml) +namespace eval ::tomlish::argdoc { + lappend PUNKARGS [list { + @id -id ::tomlish::to_toml + @cmd -name "tomlish::to_toml"\ + -summary\ + "Serialise a tomlish structure to toml text"\ + -help\ + "Encodes tomlish (the tagged-list representation produced by + tomlish::from_toml or tomlish::from_dict) as toml text. + + For tomlish obtained from tomlish::from_toml this reproduces + the original document byte for byte, including whitespace and + comments (lossless round-trip). + + Validation here is structural only - toml validity rules that + need whole-document knowledge (e.g duplicate keys/tables) are + not detected; they are the role of the dict conversion pair + tomlish::to_dict / tomlish::from_dict. + + tomlish::to_toml is an alias of tomlish::encode::tomlish. + Returns the toml text." + @leaders + list -type list -optional 0 -help\ + "tomlish tagged list" + context -type string -optional 1 -default "" -help\ + "internal recursion context tag - omit in normal use" + }] +} interp alias {} tomlish::to_toml {} tomlish::encode::tomlish # @@ -9408,12 +9555,48 @@ namespace eval tomlish::system { #[list_end] [comment {--- end definitions namespace tomlish::system ---}] } +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + #documentation-only PUNKARGS registration - discovered lazily if/when punk::args is loaded; + #adds no punk::args dependency to the tomlish library itself. + lappend ::punk::args::register::NAMESPACES ::tomlish::argdoc +} + # if {[info exists ::argc] && $::argc > 0} {} ;#not a valid way to test if main script -if {[tomlish::system::is_main_script]} { - #puts stderr "argc: $::argc args: $::argv" - set arglist $::argv +namespace eval tomlish { + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::tomlish::cmdline_main + @cmd -name "tomlish::cmdline_main"\ + -summary\ + "Run the tomlish command-line application on an argument list"\ + -help\ + "Explicit entry point for the tomlish command-line app + (usage display and -app dispatch to the tomlish::app::* + applications such as decode_to_typedjson, + encode_from_typedjson, test). + + Called automatically with \$::argv when the tomlish module + file is the main script (tclsh tomlish.tcl ...). Launchers + such as a wrapped tomlish executable's app package must + call this explicitly after package require tomlish - since + the tomlish::system::is_main_script gate (1.1.8) the app + no longer runs as a load-time side effect of ::argc/::argv + being set. + + Zeroes the global ::argv/::argc before loading dependent + packages (argument hygiene) and terminates the process via + exit on every path: 0 for success/help, 1 for usage or + application errors." + @leaders + arglist -type list -optional 0 -help\ + "command-line argument list (typically \$::argv)" + }] + } +} +proc ::tomlish::cmdline_main {arglist} { # -------------- #make sure any dependant packages that are sourced don't get any commandline args set ::argv {} @@ -9476,11 +9659,16 @@ if {[tomlish::system::is_main_script]} { } } +if {[tomlish::system::is_main_script]} { + #puts stderr "argc: $::argc args: $::argv" + tomlish::cmdline_main $::argv +} + ## Ready package provide tomlish [namespace eval tomlish { variable pkg tomlish variable version - set version 1.1.8 + set version 1.1.10 }] return diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.2.0.tm similarity index 94% rename from src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.1.tm rename to src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.2.0.tm index 8fa2cac2..a8086722 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.2.0.tm @@ -8411,38 +8411,507 @@ namespace eval punk { } puts -nonewline stdout \n } - #return list of {chan chunk} elements - namespace eval argdoc { + #punk::help topic registry + #Each registered topic has: + # - a handler proc ::punk::helptopic:: taking a context dict plus any extra words, + # returning the topic's help content as a list of {channel text} chunks + # - a punk::args definition with id ::punk::helptopic:: so that 'i help ' shows documented usage + #Registering a topic (re)generates the ::punk::help and ::punk::help_chunks punk::args definitions, + #so the documented topic choices always match the registry. + #The 'overview' handler is not a registered topic - it is what a plain 'help' displays. + #Unregistered topic words fall through to basic command-info lookup (see ::punk::help_chunks). + namespace eval helptopic { + variable topics [dict create] + + tcl::namespace::import ::punk::ansi::a ::punk::ansi::a+ + + proc register {topic aliases summary} { + variable topics + if {![llength [info commands [namespace current]::$topic]]} { + error "punk::helptopic::register - no handler proc '[namespace current]::$topic' exists for topic '$topic'" + } + dict set topics $topic [dict create aliases $aliases summary $summary] + define_docs + return + } + + #return the canonical topic name for a topic word or alias - empty string if not a registered topic + proc resolve {word} { + variable topics + dict for {topic tinfo} $topics { + if {$word eq $topic || $word in [dict get $tinfo aliases]} { + return $topic + } + } + return "" + } + + #standard command-info table as used by the help overview blocks + proc table_block {frametype title rows {minwidth 80}} { + set t [textblock::class::table new -minwidth $minwidth -show_seps 0] + $t configure -frametype $frametype + foreach row $rows { + $t add_row $row + } + $t configure_column 0 -minwidth [expr {[$t column_datawidth 0] + 2}] + $t configure_column 1 -minwidth [expr {[$t column_datawidth 1] + 1}] + $t configure -title $title + set text [$t print] + $t destroy + return $text + } + + #(re)generate the punk::args definitions for ::punk::help and ::punk::help_chunks from the registry + #so that 'i help' shows a documented topic table matching the registered topics. + proc define_docs {} { + variable topics + set choices [list] + set choiceinfo [dict create] + set choicelabels [dict create] + dict for {topic tinfo} $topics { + foreach name [list $topic {*}[dict get $tinfo aliases]] { + lappend choices $name + dict set choiceinfo $name [list [list doctype punkargs] [list subhelp [namespace current]::$topic]] + dict set choicelabels $name [dict get $tinfo summary] + } + } + set basehelp {Help system for the punk shell. + With no arguments - an overview of some key shell commands is displayed. + When the first argument is a recognised topic - help for that topic is displayed. + ('help topics' lists the available topics) + Anything else is treated as a command name - basic command info (type and + synopsis) is shown for a resolvable command, or the resolved path for an + external executable.} + set topichelp {Help topic, or command words for basic command info. (topics must match exactly - no prefix matching)} + set specs [list] + lappend specs ::punk::help help "Punk shell help system." "" + lappend specs ::punk::help_chunks punk::help_chunks "Punk shell help system - content as {channel text} chunks." "\n\nhelp_chunks returns the help content as a list of {channel text} chunks rather than emitting it." + foreach {id name summary extra} $specs { + set def "" + append def "@id -id $id" \n + append def "@cmd -name $name -summary \"$summary\" -help \"$basehelp$extra\"" \n + append def "@leaders -min 0 -max -1" \n + append def "topic -optional 1 -multiple 1 -type string -choiceprefix 0 -choicerestricted 0 -choices {$choices} -choiceinfo {$choiceinfo} -choicelabels {$choicelabels} -help \"$topichelp\"" \n + append def "@values -min 0 -max 0" + if {[punk::args::id_exists $id]} { + #quiet undefine - redefinition on registry change is expected, not noteworthy + punk::args::undefine $id 1 + } + punk::args::define $def + } + } + + #The no-topic overview of key shell commands (what a plain 'help' displays) + proc overview {context args} { + set frametype [dict get $context frametype] + set I [dict get $context I] + set NI [dict get $context NI] + set chunks [list] + + set title "[a+ brightgreen] Filesystem navigation: " + set cmdinfo [list] + lappend cmdinfo [list ./ "?${I}glob${NI}?" "view/change dir, list dirs."] + lappend cmdinfo [list .// "?${I}glob${NI}?" "view/change dir, list dirs and files"] + lappend cmdinfo [list ../ "?${I}path${NI}" "go up one dir, then to path if given"] + 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)"] + lappend chunks [list stdout [table_block $frametype $title $cmdinfo]\n] + + 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 "newns" "${I}ns${NI}" "make child namespace and switch to it"] + lappend chunks [list stdout [table_block $frametype $title $cmdinfo]\n] + + set title "[a+ brightgreen] Command help: " + set cmdinfo [list] + lappend cmdinfo [list i "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show usage for a command or ensemble subcommand"] + lappend cmdinfo [list s "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show synopsis for a command or ensemble subcommand"] + lappend cmdinfo [list eg "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show example from manpage"] + lappend cmdinfo [list corp "${I}proc${NI}" "View proc body and arguments with basic highlighting"] + lappend chunks [list stdout [table_block $frametype $title $cmdinfo]\n] + + set title "[a+ brightgreen] Miscellaneous: " + #todo - load from source code annotation? + set cmdinfo [list] + lappend cmdinfo [list dev "?${I}subcommand${NI}?" "(ensemble command to make new projects/modules and\n to generate docs)"] + lappend cmdinfo [list a? "?${I}subcommand${NI}...?" "view ANSI colours\n e.g a? web\n or individual code samples/diagnostics\n e.g a? red bold\n e.g a? underline web-orange Term-purple3"] + lappend cmdinfo [list a+ "?${I}colourcode${NI}...?" "Return ANSI codes\n e.g puts \"\[a+ purple\]purple\[a+ Green\]purple on green\[a\]\"\n [a+ purple]purple[a+ Green]purple on green[a] "] + lappend cmdinfo [list a "?${I}colourcode${NI}...?" "Return ANSI codes (with leading reset)\n e.g puts \"\[a+ purple\]purple\[a Green\]normal on green\[a\]\"\n [a+ purple]purple[a Green]normal on green[a] "] + lappend chunks [list stdout [table_block $frametype $title $cmdinfo]] + + return $chunks + } + punk::args::define { - @id -id ::punk::help_chunks - @cmd -name "punk::help_chunks"\ - -summary\ - ""\ - -help\ - "" - @opts - -- -type none - @values -min 0 -max -1 - arg -type any -optional 1 -multiple 1 + @id -id ::punk::helptopic::topics + @cmd -name "help topics" -summary "List help topics." -help "Show the table of topics known to the help system, including registered aliases for each topic." + @values -min 0 -max 0 + } + proc topics {context args} { + variable topics + set frametype [dict get $context frametype] + set t [textblock::class::table new -show_seps 0] + $t configure -frametype $frametype + $t add_column -headers [list "Topic"] + $t add_column + dict for {topic tinfo} $topics { + $t add_row [list [join [list $topic {*}[dict get $tinfo aliases]] |] [dict get $tinfo summary]] + } + $t add_row [list "*" "Look up as a command or external executable"] + $t configure_column 0 -minwidth [expr {[$t column_datawidth 0] + 4}] + set text \n[$t print] + $t destroy + return [list [list stdout $text]] + } + + punk::args::define { + @id -id ::punk::helptopic::tcl + @cmd -name "help tcl" -summary "Tcl version warnings." -help "Show the running Tcl patchlevel and build-info, with warnings for known Tcl bugs affecting this interpreter (as detected by the punk::lib::check::has_tclbug_* checks)." + @values -min 0 -max 0 + } + proc tcl {context args} { + set chunks [list] + set warningblock "" + set text "Tcl Patchlevel: [info patchlevel]" + catch { + append text \n "Tcl build-info: [::tcl::build-info]" + } + #generate warningblocks for each triggered Tcl bug in namespace ::punk::lib::check + set bugcheck_procs [info procs ::punk::lib::check::has_tclbug*] + foreach bp $bugcheck_procs { + set buginfo [$bp] + if {[dict get $buginfo bug]} { + set level unknown + if {[dict exists $buginfo level]} { + set level [dict get $buginfo level] + } + switch -- $level { + minor {set highlight [punk::ansi::a+ cyan]} + medium {set highlight [punk::ansi::a+ yellow]} + major {set highlight [punk::ansi::a+ red bold]} + default {set highlight ""} + } + append warningblock \n $highlight "warning level: $level $bp triggered." + if {[dict exists $buginfo description]} { + set indent " " + append warningblock \n "[punk::lib::indent [dict get $buginfo description] $indent]" + } + if {[dict exists $buginfo bugref] && [dict get $buginfo bugref] ne ""} { + set bugref [dict get $buginfo bugref] + append warningblock \n "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/$bugref]" + } + append warningblock [a] + } + } + + if {[catch {lsearch -stride 2 {a b} b}]} { + #has_tclbug_lsearch_strideallinline will have reported bug false because it couldn't test it. + set indent " " + append warningblock \n "[a+ web-red]warning: lsearch does not seem to support -stride option" \n + append warningblock "${indent}(Consider upgrading to a late release of tcl 8.6 or tcl 9+ )" \n + append warningblock [a] + } + lappend chunks [list stdout $text] + lappend chunks [list stderr $warningblock] + return $chunks + } + + punk::args::define { + @id -id ::punk::helptopic::env + @cmd -name "help env" -summary "punkshell environment vars." -help "Show punk-related and other relevant environment variables with their current values." + @values -min 0 -max 0 + } + proc env {context args} { + if {[catch {package require punk::config} errM]} { + return [list [list stderr "help env: punk::config package not available - no environment variable info ($errM)\n"]] + } + if {![info exists ::punk::config::punk_env_vars_config] || ![info exists ::punk::config::other_env_vars_config]} { + #punk::config::init has side effects (config dir/file creation) - don't trigger it just for help + return [list [list stderr "help env: punk::config not initialised - no environment variable info\n"]] + } + set frametype [dict get $context frametype] + set linesep [string repeat - 76] + set chunks [list] + set text "" + #todo - move to punk::config? + upvar ::punk::config::punk_env_vars_config punkenv_config + upvar ::punk::config::other_env_vars_config otherenv_config + + set known_punk [dict keys $punkenv_config] + set known_other [dict keys $otherenv_config] + append text \n + set usetable 1 + if {$usetable} { + set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] + $t configure -frametype $frametype + if {"windows" eq $::tcl_platform(platform)} { + #If any env vars have been set to empty string - this is considered a deletion of the variable on windows. + #The Tcl ::env array is linked to the underlying process view of the environment + #- but info exists ::env(var) can misreport as true if it has been deleted by setting to empty string rather than using unset. + #an 'array get' will resynchronise. + #Even if an env variable didn't exist before - setting it to empty string can get it to this inconsistent state. + array get ::env + } + #do an array read on ::env + foreach {v vinfo} $punkenv_config { + if {[info exists ::env($v)]} { + set c2 [set ::env($v)] + } else { + set c2 "(NOT SET)" + } + set help "" + if {[dict exists $vinfo help]} { + set help [dict get $vinfo help] + } + $t add_row [list $v $c2 $help] + } + $t configure_column 0 -headers [list "Punk environment vars"] + $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} + + set punktable [$t print] + $t destroy + + set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] + $t configure -frametype $frametype + foreach {v vinfo} $otherenv_config { + if {[info exists ::env($v)]} { + set env_val [set ::env($v)] + if {[string match "*_TM_PATH" $v]} { + set entries [split $env_val $::tcl_platform(pathSeparator)] + set c2 [join $entries \n] + } else { + set c2 $::env($v) + } + } else { + set c2 "(NOT SET)" + } + $t add_row [list $v $c2] + } + $t configure_column 0 -headers [list "Other environment vars"] + $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} + + set othertable [$t print] + $t destroy + #append text [textblock::join -- $punktable " " $othertable]\n + append text $punktable\n$othertable\n + } else { + + append text $linesep\n + append text "punk environment vars:\n" + append text $linesep\n + set col1 [string repeat " " 25] + set col2 [string repeat " " 50] + foreach v $known_punk { + set c1 [overtype::left $col1 $v] + if {[info exists ::env($v)]} { + set c2 [overtype::left $col2 [set ::env($v)]] + } else { + set c2 [overtype::right $col2 "(NOT SET)"] + } + append text "$c1 $c2\n" + } + append text $linesep\n + } + + lappend chunks [list stdout $text] + return $chunks + } + + punk::args::define { + @id -id ::punk::helptopic::console + @cmd -name "help console" -summary "Console behaviour tests and warnings." -help "Run some console/terminal behaviour tests (control string hiding, grapheme cluster support, cursor position query timing) and report warnings. Requires a responsive interactive console." + @values -min 0 -max 0 + } + proc console {context args} { + set chunks [list] + set warningblock "" + set term_env_vars {TERM TERM_PROGRAM TERM_PROGRAM_VERSION COLORTERM} + set term_dict [dict create] + foreach e $term_env_vars { + if {[info exists ::env($e)]} { + dict set term_dict $e [set ::env($e)] + } else { + dict set term_dict $e "(NOT SET)" + } + } + set text "Terminal environment variables:\n" + append text [punk::lib::showdict $term_dict] \n + lappend chunks [list stdout $text] + set text "" + set indent [string repeat " " [string length "WARNING: "]] + + 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 { + + if {![catch {punk::console::class_info} console_class_info]} { + set text "Terminal class info (from device secondary attributes query to terminal):\n" + append text [punk::lib::showdict $console_class_info] \n + } else { + set text "Unable to query terminal class info - err:$console_class_info\n" + } + lappend chunks [list stdout $text] + + 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" + } + } + 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" + } + + 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" + } + + + 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 posn [punk::console::get_cursor_pos] ;#warmup call - and test if works + if {$posn eq ""} { + append warningblock \n "WARNING: terminal doesn't respond to cursor position query - may cause display bugs in some cases." + } else { + set timeresult [timerate {set cpos [punk::console::get_cursor_pos]}] + lassign [split $cpos {;}] row col + if {![string is integer -strict $row] || ![string is integer -strict $col]} { + append warningblock \n "WARNING: terminal returns non-integer values for cursor position query - may cause display bugs in some cases. got row:'$row' col:'$col'" + } else { + set micros [lindex $timeresult 0] + if {$micros > 2000} { + append warningblock \n "WARNING: terminal cursor position query is very slow ($micros microseconds - expect < 2000us )" + append warningblock \n $indent "- may cause display lag/bugs in some cases." + } else { + if {$micros > 1000} { + set text "\n[a+ yellow]Terminal cursor position query test passed." + append text \n $indent "Response time: ${micros} microseconds (OK, good would be <= 1000us).[a]" + + } else { + set text "[a+ green]Terminal cursor position query test passed." + append text \n $indent "Response time: ${micros} microseconds (GOOD).[a]" + } + lappend chunks [list stdout $text] + } + } + } + + + if {![string length $warningblock]} { + set text "[a+ green]No terminal warnings[a]\n" + lappend chunks [list stdout $text] + } else { + set mode [punk::console::mode] + if {$mode eq "line"} { + append warningblock \n "Terminal appears to be in line mode. Consider switching to raw mode and re-testing (command: punk::console::mode raw)." + } + } + puts stdout [punk::ansi::move_back 200] ;#hack for some horizontal position bugs where the above tests can leave the cursor in the wrong place for the next output. + #200 is arbitrary large number to move back enough to get to start of line. + } + lappend chunks [list stderr $warningblock] + return $chunks } + + register topics {help} "List help topics" + register tcl {} "Tcl version warnings" + register env {environment} "punkshell environment vars" + register console {term terminal} "Some console behaviour tests and warnings" } + + #return list of {chan chunk} elements proc help_chunks {args} { - set argd [punk::args::parse $args withid ::punk::help_chunks] + set argd [punk::args::parse $args withid ::punk::help] lassign [dict values $argd] leaders opts values received - if {[dict exists $values arg]} { - set topicparts [dict get $values arg] + if {[dict exists $leaders topic]} { + set topicparts [dict get $leaders topic] } else { set topicparts [list ""] } - #set topic [lindex $args end] - #set argopts [lrange $args 0 end-1] - set chunks [list] - set linesep [string repeat - 76] - - set warningblock "" set I [punk::ansi::a+ italic] set NI [punk::ansi::a+ noitalic] @@ -8471,6 +8940,8 @@ namespace eval punk { } + set context [dict create cols $cols rows $rows frametype $frametype I $I NI $NI] + # ------------------------------------------------------- set logoblock "" if {[catch { @@ -8483,473 +8954,54 @@ namespace eval punk { set title "[a+ brightgreen] Help System: " set cmdinfo [list] lappend cmdinfo [list help "?${I}topic${NI}?" "This help.\nTo see available subitems type:\nhelp topics\n\nFor an unrecognised ${I}topic${NI}\nhelp will look for basic\ninfo for it as a command.\n"] - set t [textblock::class::table new -minwidth 51 -show_seps 0] - $t configure -frametype $frametype - foreach row $cmdinfo { - $t add_row $row - } - set width_0 [$t column_datawidth 0] - $t configure_column 0 -minwidth [expr {$width_0 + 2}] - set width_1 [$t column_datawidth 1] - $t configure_column 1 -minwidth [expr {$width_1 + 1}] - $t configure -title $title - set text [$t print] + set text [helptopic::table_block $frametype $title $cmdinfo 51] set introblock [textblock::join -- $logoblock $text] lappend chunks [list stdout $introblock\n] # ------------------------------------------------------- - switch -- [lindex $topicparts 0] { - "" { - - # ------------------------------------------------------- - set title "[a+ brightgreen] Filesystem navigation: " - set cmdinfo [list] - lappend cmdinfo [list ./ "?${I}glob${NI}?" "view/change dir, list dirs."] - lappend cmdinfo [list .// "?${I}glob${NI}?" "view/change dir, list dirs and files"] - lappend cmdinfo [list ../ "?${I}path${NI}" "go up one dir, then to path if given"] - 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] - $t configure -frametype $frametype - foreach row $cmdinfo { - $t add_row $row - } - set width_0 [$t column_datawidth 0] - $t configure_column 0 -minwidth [expr {$width_0 + 2}] - set width_1 [$t column_datawidth 1] - $t configure_column 1 -minwidth [expr {$width_1 + 1}] - $t configure -title $title - - set text "" - append text [$t print] - lappend chunks [list stdout $text\n] - # ------------------------------------------------------- - - - # ------------------------------------------------------- - 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 "newns" "${I}ns${NI}" "make child namespace and switch to it"] - set t [textblock::class::table new -minwidth 80 -show_seps 0] - $t configure -frametype $frametype - foreach row $cmdinfo { - $t add_row $row - } - set width_0 [$t column_datawidth 0] - $t configure_column 0 -minwidth [expr {$width_0 + 2}] - set width_1 [$t column_datawidth 1] - $t configure_column 1 -minwidth [expr {$width_1 + 1}] - $t configure -title $title - - set text "" - append text [$t print] - lappend chunks [list stdout $text\n] - # ------------------------------------------------------- - - # ------------------------------------------------------- - set title "[a+ brightgreen] Command help: " - set cmdinfo [list] - lappend cmdinfo [list i "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show usage for a command or ensemble subcommand"] - lappend cmdinfo [list s "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show synopsis for a command or ensemble subcommand"] - lappend cmdinfo [list eg "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show example from manpage"] - lappend cmdinfo [list corp "${I}proc${NI}" "View proc body and arguments with basic highlighting"] - set t [textblock::class::table new -minwidth 80 -show_seps 0] - $t configure -frametype $frametype - foreach row $cmdinfo { - $t add_row $row - } - set width_0 [$t column_datawidth 0] - $t configure_column 0 -minwidth [expr {$width_0 + 2}] - set width_1 [$t column_datawidth 1] - $t configure_column 1 -minwidth [expr {$width_1 + 1}] - $t configure -title $title - - set text "" - append text [$t print] - lappend chunks [list stdout $text\n] - # ------------------------------------------------------- - - - set title "[a+ brightgreen] Miscellaneous: " - #todo - load from source code annotation? - set cmdinfo [list] - lappend cmdinfo [list dev "?${I}subcommand${NI}?" "(ensemble command to make new projects/modules and\n to generate docs)"] - lappend cmdinfo [list a? "?${I}subcommand${NI}...?" "view ANSI colours\n e.g a? web\n or individual code samples/diagnostics\n e.g a? red bold\n e.g a? underline web-orange Term-purple3"] - lappend cmdinfo [list a+ "?${I}colourcode${NI}...?" "Return ANSI codes\n e.g puts \"\[a+ purple\]purple\[a+ Green\]purple on green\[a\]\"\n [a+ purple]purple[a+ Green]purple on green[a] "] - lappend cmdinfo [list a "?${I}colourcode${NI}...?" "Return ANSI codes (with leading reset)\n e.g puts \"\[a+ purple\]purple\[a Green\]normal on green\[a\]\"\n [a+ purple]purple[a Green]normal on green[a] "] - - set t [textblock::class::table new -minwidth 80 -show_seps 0] - $t configure -frametype $frametype - foreach row $cmdinfo { - $t add_row $row - } - set width_0 [$t column_datawidth 0] - $t configure_column 0 -minwidth [expr {$width_0 + 2}] - set width_1 [$t column_datawidth 1] - $t configure_column 1 -minwidth [expr {$width_1 + 1}] - $t configure -title $title - - set text "" - append text [$t print] - lappend chunks [list stdout $text] - # ------------------------------------------------------- - - } - tcl { - set text "Tcl Patchlevel: [info patchlevel]" - catch { - append text \n "Tcl build-info: [::tcl::build-info]" - } - #generate warningblocks for each triggered Tcl bug in namespace ::punk::lib::check - set bugcheck_procs [info procs ::punk::lib::check::has_tclbug*] - foreach bp $bugcheck_procs { - set buginfo [$bp] - if {[dict get $buginfo bug]} { - set level unknown - if {[dict exists $buginfo level]} { - set level [dict get $buginfo level] - } - switch -- $level { - minor {set highlight [punk::ansi::a+ cyan]} - medium {set highlight [punk::ansi::a+ yellow]} - major {set highlight [punk::ansi::a+ red bold]} - default {set highlight ""} - } - append warningblock \n $highlight "warning level: $level $bp triggered." - if {[dict exists $buginfo description]} { - set indent " " - append warningblock \n "[punk::lib::indent [dict get $buginfo description] $indent]" - } - if {[dict exists $buginfo bugref] && [dict get $buginfo bugref] ne ""} { - set bugref [dict get $buginfo bugref] - append warningblock \n "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/$bugref]" - } - append warningblock [a] - } - } - - if {[catch {lsearch -stride 2 {a b} b}]} { - #has_tclbug_lsearch_strideallinline will have reported bug false because it couldn't test it. - set indent " " - append warningblock \n "[a+ web-red]warning: lsearch does not seem to support -stride option" \n - append warningblock "${indent}(Consider upgrading to a late release of tcl 8.6 or tcl 9+ )" \n - append warningblock [a] - } - lappend chunks [list stdout $text] - } - env - environment { - set text "" - #todo - move to punk::config? - upvar ::punk::config::punk_env_vars_config punkenv_config - upvar ::punk::config::other_env_vars_config otherenv_config - - set known_punk [dict keys $punkenv_config] - set known_other [dict keys $otherenv_config] - append text \n - set usetable 1 - if {$usetable} { - set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] - $t configure -frametype $frametype - if {"windows" eq $::tcl_platform(platform)} { - #If any env vars have been set to empty string - this is considered a deletion of the variable on windows. - #The Tcl ::env array is linked to the underlying process view of the environment - #- but info exists ::env(var) can misreport as true if it has been deleted by setting to empty string rather than using unset. - #an 'array get' will resynchronise. - #Even if an env variable didn't exist before - setting it to empty string can get it to this inconsistent state. - array get ::env - } - #do an array read on ::env - foreach {v vinfo} $punkenv_config { - if {[info exists ::env($v)]} { - set c2 [set ::env($v)] - } else { - set c2 "(NOT SET)" - } - set help "" - if {[dict exists $vinfo help]} { - set help [dict get $vinfo help] - } - $t add_row [list $v $c2 $help] - } - $t configure_column 0 -headers [list "Punk environment vars"] - $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} - - set punktable [$t print] - $t destroy - - set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] - $t configure -frametype $frametype - foreach {v vinfo} $otherenv_config { - if {[info exists ::env($v)]} { - set env_val [set ::env($v)] - if {[string match "*_TM_PATH" $v]} { - set entries [split $env_val $::tcl_platform(pathSeparator)] - set c2 [join $entries \n] - } else { - set c2 $::env($v) - } - } else { - set c2 "(NOT SET)" - } - $t add_row [list $v $c2] - } - $t configure_column 0 -headers [list "Other environment vars"] - $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} - - set othertable [$t print] - $t destroy - #append text [textblock::join -- $punktable " " $othertable]\n - append text $punktable\n$othertable\n + set word0 [lindex $topicparts 0] + set topic [helptopic::resolve $word0] + if {$word0 eq ""} { + #no topic supplied - overview of key shell commands + lappend chunks {*}[helptopic::overview $context {*}[lrange $topicparts 1 end]] + } elseif {$topic ne ""} { + lappend chunks {*}[helptopic::$topic $context {*}[lrange $topicparts 1 end]] + } else { + #not a registered topic - fall through to basic command info lookup + set text "" + set cinfo [uplevel 1 [list ::punk::ns::cmdwhich [lindex $topicparts 0]]] + set wtype [dict get $cinfo whichtype] + if {$wtype eq "notfound"} { + set externalinfo [auto_execok [lindex $topicparts 0]] + if {[string length $externalinfo]} { + set text "$topicparts" + append text \n "Base type: External command" + append text \n "$externalinfo [lrange $topicparts 1 end]" } else { - - append text $linesep\n - append text "punk environment vars:\n" - append text $linesep\n - set col1 [string repeat " " 25] - set col2 [string repeat " " 50] - foreach v $known_punk { - set c1 [overtype::left $col1 $v] - if {[info exists ::env($v)]} { - set c2 [overtype::left $col2 [set ::env($v)]] - } else { - set c2 [overtype::right $col2 "(NOT SET)"] - } - append text "$c1 $c2\n" - } - append text $linesep\n + set text "$topicparts\n" + append text "No matching internal or external command found" } - - lappend chunks [list stdout $text] - } - console - term - terminal { - set term_env_vars {TERM TERM_PROGRAM TERM_PROGRAM_VERSION COLORTERM} - set term_dict [dict create] - foreach e $term_env_vars { - if {[info exists ::env($e)]} { - dict set term_dict $e [set ::env($e)] - } else { - dict set term_dict $e "(NOT SET)" - } - } - set text "Terminal environment variables:\n" - append text [punk::lib::showdict $term_dict] \n - lappend chunks [list stdout $text] - set text "" - set indent [string repeat " " [string length "WARNING: "]] - - 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 { - - if {![catch {punk::console::class_info} console_class_info]} { - set text "Terminal class info (from device secondary attributes query to terminal):\n" - append text [punk::lib::showdict $console_class_info] \n - } else { - set text "Unable to query terminal class info - err:$console_class_info\n" - } - lappend chunks [list stdout $text] - - 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" - } - } - 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" - } - - 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" - } - - - 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 posn [punk::console::get_cursor_pos] ;#warmup call - and test if works - if {$posn eq ""} { - append warningblock \n "WARNING: terminal doesn't respond to cursor position query - may cause display bugs in some cases." - } else { - set timeresult [timerate {set cpos [punk::console::get_cursor_pos]}] - lassign [split $cpos {;}] row col - if {![string is integer -strict $row] || ![string is integer -strict $col]} { - append warningblock \n "WARNING: terminal returns non-integer values for cursor position query - may cause display bugs in some cases. got row:'$row' col:'$col'" - } else { - set micros [lindex $timeresult 0] - if {$micros > 2000} { - append warningblock \n "WARNING: terminal cursor position query is very slow ($micros microseconds - expect < 2000us )" - append warningblock \n $indent "- may cause display lag/bugs in some cases." - } else { - if {$micros > 1000} { - set text "\n[a+ yellow]Terminal cursor position query test passed." - append text \n $indent "Response time: ${micros} microseconds (OK, good would be <= 1000us).[a]" - - } else { - set text "[a+ green]Terminal cursor position query test passed." - append text \n $indent "Response time: ${micros} microseconds (GOOD).[a]" - } - lappend chunks [list stdout $text] - } - } - } - - - if {![string length $warningblock]} { - set text "[a+ green]No terminal warnings[a]\n" - lappend chunks [list stdout $text] + } else { + set text "[dict get $cinfo which] [lrange $topicparts 1 end]" + append text \n "Base type: $wtype" + set synopsis [uplevel 1 [list ::punk::ns::synopsis {*}$topicparts]] + set synshow "" + foreach sline [split $synopsis \n] { + if {[regexp {\s*#.*} $sline]} { + append synshow [punk::ansi::a+ bold term-darkgreen Term-white]$sline[punk::ansi::a] \n } else { - set mode [punk::console::mode] - if {$mode eq "line"} { - append warningblock \n "Terminal appears to be in line mode. Consider switching to raw mode and re-testing (command: punk::console::mode raw)." - } + append synshow $sline \n } - puts stdout [punk::ansi::move_back 200] ;#hack for some horizontal position bugs where the above tests can leave the cursor in the wrong place for the next output. - #200 is arbitrary large number to move back enough to get to start of line. - } - } - topics - help { - set text "" - set topics [dict create {*}{ - "topics|help" "List help topics" - "tcl" "Tcl version warnings" - "env|environment" "punkshell environment vars" - "console|terminal" "Some console behaviour tests and warnings" - "*" "Try to find help on the topic as a command or external executable" - }] - - set t [textblock::class::table new -show_seps 0] - $t configure -frametype $frametype - $t add_column -headers [list "Topic"] - $t add_column - foreach {k v} $topics { - $t add_row [list $k $v] } - set widest0 [$t column_datawidth 0] - $t configure_column 0 -minwidth [expr {$widest0 + 4}] - append text \n [$t print] - - lappend chunks [list stdout $text] - } - default { - set text "" - set cinfo [uplevel 1 [list ::punk::ns::cmdwhich [lindex $topicparts 0]]] - set wtype [dict get $cinfo whichtype] - if {$wtype eq "notfound"} { - set externalinfo [auto_execok [lindex $topicparts 0]] - if {[string length $externalinfo]} { - set text "$topicparts" - append text \n "Base type: External command" - append text \n "$externalinfo [lrange $topicparts 1 end]" - } else { - set text "$topicparts\n" - append text "No matching internal or external command found" - } - } else { - set text "[dict get $cinfo which] [lrange $topicparts 1 end]" - append text \n "Base type: $wtype" - set synopsis [uplevel 1 [list ::punk::ns::synopsis {*}$topicparts]] - set synshow "" - foreach sline [split $synopsis \n] { - if {[regexp {\s*#.*} $sline]} { - append synshow [punk::ansi::a+ bold term-darkgreen Term-white]$sline[punk::ansi::a] \n - } else { - append synshow $sline \n - } - } - if {[string index $synshow end] eq "\n"} { - set synshow [string range $synshow 0 end-1] - } - append text \n $synshow + if {[string index $synshow end] eq "\n"} { + set synshow [string range $synshow 0 end-1] } - lappend chunks [list stdout $text] + append text \n $synshow } + lappend chunks [list stdout $text] } - - - lappend chunks [list stderr $warningblock] return $chunks } proc mode {{raw_or_line query}} { @@ -9298,7 +9350,7 @@ punkcheck::cli set_alias punkcheck package provide punk [namespace eval punk { #FUNCTL variable version - set version 0.1.1 + set version 0.2.0 }] diff --git a/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.3.tm similarity index 99% rename from src/bootsupport/modules/punk/args-0.2.1.tm rename to src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.3.tm index 21ee1c6d..e8b2c3bf 100644 --- a/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.3.tm @@ -8,7 +8,7 @@ # (C) 2024 # # @@ Meta Begin -# Application punk::args 0.2.1 +# Application punk::args 0.2.3 # Meta platform tcl # Meta license # @@ Meta End @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_punk::args 0 0.2.1] +#[manpage_begin punkshell_module_punk::args 0 0.2.3] #[copyright "2024"] #[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] #[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] @@ -871,19 +871,46 @@ tcl::namespace::eval punk::args { -choicerestricted Whether values not specified in -choices or -choicegroups are allowed. Defaults to true. + When false, an input that matches no choice - including an + ambiguous prefix, a prefix of a -choiceprefixdenylist entry, + or a -choiceprefixreservelist word - is accepted unchanged as + an ordinary value (subject to -type validation) instead of + raising an error. This passthrough is the pattern for + arguments that mix a known choice set with free-form values + (e.g. a help topic word falling through to command lookup). -choiceprefix This specifies whether unique prefixes are able to be used instead of the complete string. This is calculated using tcl::prefix::match - and will display in the autogenerated usage output. Defaults to true. + A matching prefix is normalized: the parse result contains + the full choice string, never the typed prefix - so callers + switch on canonical choice values only. The usage display + highlights each choice's minimal accepted prefix (a choice + in -choiceprefixdenylist displays fully highlighted - the + whole word is required). -choiceprefixdenylist {} These choices should match exactly a choice entry in one of the settings -choices or -choicegroups. These will still be used in prefix calculation - but the full choice argument must be entered to select the choice. + A shorter prefix of a denied choice is an error when + -choicerestricted is true, and passes through as an ordinary + (non-choice) value when -choicerestricted is false - use this + to keep short words available for other purposes (e.g. with + 'help' denied, h/he/hel remain free-form values). -choiceprefixreservelist {} These choices are additional values used in prefix calculation. The values will not be added to the list of available choices. + A reserved word never matches: entered exactly it is an error + when -choicerestricted is true and passes through when false, + as do any shorter words it shadows into ambiguity. This gives + per-choice control of the minimum accepted prefix by reserving + phantom entries: e.g. -choices {environment} + -choiceprefixreservelist {en} means e/en do not match while + env, envi, ... environment all normalize to environment. + (To require a longer minimum, reserve each shorter form: + reserving {en env} raises the minimum to envi.) -choicegroups {} Generally this would be used instead of -choices to allow usage display of choices grouped by some name (or the empty @@ -6156,7 +6183,7 @@ tcl::namespace::eval punk::args { #puts stderr ">>>_get_dict_can_assign_value idx:$idx v:[lindex $values $idx] consumed:$alloc_count thistype:$thistype" set d [dict create consumed $alloc_count resultlist $resultlist typelist $newtypelist] } else { - puts stderr ">>>_get_dict_can_assign_value NOT alloc_ok: idx:$idx v:[lindex $values $idx] consumed:$alloc_count thistype:$thistype" + #puts stderr ">>>_get_dict_can_assign_value NOT alloc_ok: idx:$idx v:[lindex $values $idx] consumed:$alloc_count thistype:$thistype" set d [dict create consumed 0 resultlist {} typelist $thistype] } #puts ">>>> _get_dict_can_assign_value $d" @@ -9835,7 +9862,10 @@ tcl::namespace::eval punk::args { set argname [dict get $lookup_optset $fullflag] #idents should already have correct parsekey } else { - puts stderr "punk::args::get_dict unable to find $fullflag in $lookup_optset (parsekey:$parsekey) (value_group: $value_group)" + #adhoc option (allowed via "@opts -any|-arbitrary true") - not in lookup_optset. + #argstate/arg_checks were populated for it under its raw supplied name at scan time. + set argname $fullflag + #puts stderr "punk::args::get_dict unable to find $fullflag in $lookup_optset (parsekey:$parsekey) (value_group: $value_group)" } } else { if {[dict exists $lookup_optset $argname_or_ident]} { @@ -9850,7 +9880,15 @@ tcl::namespace::eval punk::args { set parsekey [string trimright [lindex [split $argname |] end] =] } } else { - puts stderr "punk::args::get_dict unable to find $argname_or_ident in $lookup_optset (value_group: $value_group)" + #adhoc option (allowed via "@opts -any|-arbitrary true") - not in lookup_optset. + #argstate/arg_checks were populated for it under its raw supplied name at scan time. + set argname $argname_or_ident + if {$pkoverride ne ""} { + set parsekey $pkoverride + } else { + set parsekey [string trimright [lindex [split $argname |] end] =] + } + #puts stderr "punk::args::get_dict unable to find $argname_or_ident in $lookup_optset (value_group: $value_group)" } } } else { @@ -12357,7 +12395,7 @@ package provide punk::args [tcl::namespace::eval punk::args { tcl::namespace::path {::punk::args::lib ::punk::args::system} variable pkg punk::args variable version - set version 0.2.1 + set version 0.2.3 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.1.tm similarity index 99% rename from src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm rename to src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.1.tm index ad3cd57e..114d980b 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.1.tm @@ -7,7 +7,7 @@ # (C) 2023 # # @@ Meta Begin -# Application punk::ns 0.1.0 +# Application punk::ns 0.1.1 # Meta platform tcl # Meta license # @@ Meta End @@ -4633,7 +4633,7 @@ y" {return quirkykeyscript} set vline [punk::args::ensemble_subcommands_definition -columns 2 $origin] set autoid "(autodef)$origin" - puts "ENSEMBLE auto def $autoid (generate_autodef)" + #puts "ENSEMBLE auto def $autoid (generate_autodef)" #A namespace can contain spaces, so an ensemble command can contain spaces. We must quote the -id value in the autodef set argdef [punk::lib::tstr -return string { @id -id "${$autoid}" @@ -4699,7 +4699,7 @@ y" {return quirkykeyscript} append argdef \n "@formdisplay -body {$tepamhelp}" punk::args::define $argdef } else { - puts "PROC auto def $autoid (generate_autodef)" + #puts "PROC auto def $autoid (generate_autodef)" #to handle procs like ":" (eg used by colin's bytecode based expr replacement) or other names of the form ":xyz" #we can't use 'info args :::' - tcl won't find it set ns [nsprefix $origin] @@ -5026,7 +5026,7 @@ y" {return quirkykeyscript} if {[punk::args::id_exists "$origin [lindex $args $i]"]} { set a [lindex $args $i] #review - tests? - puts stderr "cmd_traverse - skipping to documented subcommand '$origin $a'" + #puts stderr "cmd_traverse - skipping to documented subcommand '$origin $a'" #we can only seek beyond an undocumented subcommand level via a space delimited path, as we can make no assumption about the actual location of a subcommand relative to its parent #There could be a different command at for example "${origin}::$a" which is unrelated to the actual resolution path. set docid_exists 1 @@ -5120,7 +5120,7 @@ y" {return quirkykeyscript} lappend resolvedargs $q lpop queryargs_untested 0 lappend eparams $q - puts stderr "---> cmd_traverse ensembleparam $q ($lname)" + #puts stderr "---> cmd_traverse ensembleparam $q ($lname)" #puts stderr "arginfo: $arginfo" #puts stderr "---> eparams: $eparams" #puts stderr "---> existing args: $args" @@ -5304,7 +5304,7 @@ y" {return quirkykeyscript} } } #REVIEW!!! - puts stderr "cmd_traverse 10 $origin $resolvedargs $queryargs_untested $docid - review" + #puts stderr "cmd_traverse 10 $origin $resolvedargs $queryargs_untested $docid - review" return [list 10 $origin $resolvedargs $queryargs_untested $docid] } @@ -7591,6 +7591,6 @@ namespace eval ::punk::args::register { ## Ready package provide punk::ns [tcl::namespace::eval punk::ns { variable version - set version 0.1.0 + set version 0.1.1 }] return \ No newline at end of file diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.1.tm similarity index 98% rename from src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm rename to src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.1.tm index 38b1f3fd..8ad1d774 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.1.tm @@ -8,7 +8,7 @@ # (C) 2024 # # @@ Meta Begin -# Application punk::packagepreference 0.1.0 +# Application punk::packagepreference 0.1.1 # Meta platform tcl # Meta license # @@ Meta End @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_punk::packagepreference 0 0.1.0] +#[manpage_begin punkshell_module_punk::packagepreference 0 0.1.1] #[copyright "2024"] #[titledesc {punkshell package/module loading}] [comment {-- Name section and table of contents description --}] #[moddesc {package/module load}] [comment {-- Description at end of page heading --}] @@ -321,7 +321,9 @@ tcl::namespace::eval punk::packagepreference { if {[catch {thread::id} threadid]} { set threadid "unknown-threadid" } - puts stdout "punk::packagepreference overloaded 'package require': Loaded punk::args::moduledoc::$dp for package '$pkg' threadid: $threadid" + #notice goes to stderr: stdout must stay clean for script/exec contexts + #(e.g the punk executable's 'script' subcommand - machine-consumed output) + puts stderr "punk::packagepreference overloaded 'package require': Loaded punk::args::moduledoc::$dp for package '$pkg' threadid: $threadid" } } #--------------------------------------------------------------- @@ -487,7 +489,7 @@ namespace eval ::punk::args::register { package provide punk::packagepreference [tcl::namespace::eval punk::packagepreference { variable pkg punk::packagepreference variable version - set version 0.1.0 + set version 0.1.1 }] return diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.2.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.2.2.tm similarity index 93% rename from src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.2.1.tm rename to src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.2.2.tm index 5ad6a0dc..0ae49215 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.2.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.2.2.tm @@ -7,7 +7,7 @@ # (C) 2023 # # @@ Meta Begin -# Application punk::path 0.2.1 +# Application punk::path 0.2.2 # Meta platform tcl # Meta license # @@ Meta End @@ -17,7 +17,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_punk::path 0 0.2.1] +#[manpage_begin punkshell_module_punk::path 0 0.2.2] #[copyright "2023"] #[titledesc {Filesystem path utilities}] [comment {-- Name section and table of contents description --}] #[moddesc {punk path filesystem utils}] [comment {-- Description at end of page heading --}] @@ -485,6 +485,87 @@ namespace eval punk::path { return relative } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::punk::path::scriptlib_resolve + @cmd -name "punk::path::scriptlib_resolve"\ + -summary\ + "Resolve a scriptlib script name to a path using the punk kit search policy"\ + -help\ + "Resolves a relative script name (the part after a 'lib:' prefix + in punk executable launch arguments) against the scriptlib + locations, in the same order the punk shell uses: + + 1. the kit vfs internal scriptlib (/app/scriptlib, + or /scriptlib for an unwrapped kit directory). + Internal scripts are deliberately NOT overridable by + external files (integrity and performance). + 2. /scriptlib - e.g /scriptlib for + an executable in /bin. + 3. /scriptlib. + + If the name's extension (lowercased) is not one of the known + scriptlib extensions (.tcl .py .pl .ps1 .sh), '.tcl' is + appended - only .tcl scripts may be named extensionlessly. + + Returns a dict with keys: + path - resolved absolute path, or empty string if not found + scriptname - the name searched for (extension applied) + candidates - the locations that were (or would be) checked, + for use in error messages. + Raises an error if name is not a relative path." + @leaders + name -type string -optional 0 -help\ + "relative script name, with or without a known extension + (any leading lib: prefix should already be stripped)" + }] + } + proc scriptlib_resolve {name} { + #shared resolution policy for the 'lib:' script prefix - used by the punk + #executable 'script' subcommand (app-punkscript); app-punkshell's shell + #subcommand encodes the same policy (todo: refactor it onto this proc). + if {[lindex [pathtype $name] 0] ne "relative"} { + error "punk::path::scriptlib_resolve name must be a relative path (got '$name')" + } + set known_extensions [list .tcl .py .pl .ps1 .sh] + if {[string tolower [file extension $name]] ni $known_extensions} { + #only .tcl scripts allowed to be called extensionlessly + set scriptname $name.tcl + } else { + set scriptname $name + } + set exepath [file dirname [file normalize [file join [info nameofexecutable] ___]]] ;#symlink resolve + set candidates [list] + #1) kit-internal scriptlib - not overridable externally + set has_zipfs_command [expr {[info commands ::tcl::zipfs::root] ne ""}] + set kit_base "" + if {$has_zipfs_command && [file exists [tcl::zipfs::root]]} { + set kit_base [tcl::zipfs::root] + } elseif {[file type $exepath] eq "directory"} { + set kit_base $exepath + } + set kit_libdir "" + if {$has_zipfs_command && $kit_base ne "" && [file exists $kit_base/app/scriptlib]} { + set kit_libdir $kit_base/app/scriptlib + } elseif {[file exists $exepath/scriptlib]} { + set kit_libdir $exepath/scriptlib + } + if {$kit_libdir ne ""} { + lappend candidates $kit_libdir/$scriptname + if {[file exists $kit_libdir/$scriptname]} { + return [dict create path $kit_libdir/$scriptname scriptname $scriptname candidates $candidates] + } + } + #2,3) external scriptlib folders relative to the executable location + set exedir [file dirname $exepath] + foreach dir [list [file join $exedir scriptlib] [file join [file dirname $exedir] scriptlib]] { + lappend candidates [file join $dir $scriptname] + if {[file isdirectory $dir] && [file exists [file join $dir $scriptname]]} { + return [dict create path [file join $dir $scriptname] scriptname $scriptname candidates $candidates] + } + } + return [dict create path "" scriptname $scriptname candidates $candidates] + } proc plain {str} { set str [string map "\\\\ /" $str] @@ -1598,12 +1679,19 @@ namespace eval punk::path::system { } + +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + #documentation-only PUNKARGS registration - discovered lazily if/when punk::args loads + lappend ::punk::args::register::NAMESPACES ::punk::path::argdoc +} + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready package provide punk::path [namespace eval punk::path { variable pkg punk::path variable version - set version 0.2.1 + set version 0.2.2 }] return diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.2.3.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.2.4.tm similarity index 99% rename from src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.2.3.tm rename to src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.2.4.tm index 4f64e822..d060aced 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.2.3.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.2.4.tm @@ -2813,8 +2813,11 @@ namespace eval shellfilter { set syslog [dict get $opts -syslog] dict unset opts -syslog set runtag "shellfilter-run" - set tid [::shellfilter::log::open $runtag [list -syslog 127.0.0.1:514]] - #set tid [::shellfilter::log::open $runtag [list -syslog $syslog]] + #honor the -syslog option (default empty) - the previous hardcoded 127.0.0.1:514 was a + #debug leftover. With no -syslog and no -file the runtag log worker is a noop (no thread + #is created). Syslog remains supported when explicitly configured; see G-036 for the + #Tcl 9 console+udp worker wedge that the always-on syslog worker exposed on exit/quit. + set tid [::shellfilter::log::open $runtag [list -syslog $syslog]] log::info {::shellfilter::log::write $runtag " opts: $opts"} log::info {::shellfilter::log::write $runtag " commandlist:'$commandlist' listlen:$listlen strlen:[string length $commandlist]"} @@ -3827,5 +3830,5 @@ namespace eval shellfilter { package provide shellfilter [namespace eval shellfilter { variable version - set version 0.2.3 + set version 0.2.4 }] diff --git a/src/bootsupport/modules/shellthread-1.6.2.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellthread-1.6.3.tm similarity index 97% rename from src/bootsupport/modules/shellthread-1.6.2.tm rename to src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellthread-1.6.3.tm index 79d12149..cd0c83c6 100644 --- a/src/bootsupport/modules/shellthread-1.6.2.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellthread-1.6.3.tm @@ -788,8 +788,12 @@ namespace eval shellthread::manager { foreach workertid $subscriberless_workers { if {$workertid ni $shuttingdown_workers} { if {$workertid ni $free_threads && $workertid ne "noop"} { - #JMN - thread::send $workertid {set ::shellthread::worker::settings $::shellthread::worker::settings_defaults} + #Must be async: unsubscribe is on the exit/quit teardown path and a worker whose + #event loop has stopped servicing events (G-036: Tcl 9 console+udp worker wedge) + #would block a synchronous send forever, freezing the shell. Async is safe - + #sends to a thread are processed FIFO, so a later reuse via new_worker sees the + #settings reset applied before anything it sends. + thread::send -async $workertid {set ::shellthread::worker::settings $::shellthread::worker::settings_defaults} #todo - log freeing up of thread lappend free_threads $workertid } @@ -812,7 +816,10 @@ namespace eval shellthread::manager { } proc get_tag_config {tag} { - #review + #review - bare synchronous thread::send: blocks forever if the worker's event loop is + #wedged (G-036 hazard class). Reached from new_worker when a tag already has a live + #worker. Needs a result so can't simply go async - convert to async + vwait-with-timeout + #if this path shows up in a hang. variable workers if {![dict exists $workers $tag]} { error "shellthread::manager::get_tag_config error no existing tag $tag" @@ -858,10 +865,13 @@ namespace eval shellthread::manager { set timedout 1 break } else { - after cancel $timeout_timer + #Do not cancel the timeout timer until all awaited workers have responded - + #cancelling on the first response left later vwait iterations unbounded, so a + #wedged worker (G-036) after a healthy one hung shutdown forever. lappend ended $::shellthread::waitfor } } + after cancel $timeout_timer } set free_threads [list] return [dict create existed $waiting_for ended $ended timedout $timedout allthreads [thread::names]] @@ -963,7 +973,7 @@ namespace eval shellthread::manager { package provide shellthread [namespace eval shellthread { variable version - set version 1.6.2 + set version 1.6.3 }] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.8.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.10.tm similarity index 98% rename from src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.8.tm rename to src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.10.tm index e1be4767..68ac58f8 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.8.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.10.tm @@ -7,7 +7,7 @@ # (C) 2024 # # @@ Meta Begin -# Application tomlish 1.1.8 +# Application tomlish 1.1.10 # Meta platform tcl # Meta license # @@ Meta End @@ -17,7 +17,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin tomlish_module_tomlish 0 1.1.8] +#[manpage_begin tomlish_module_tomlish 0 1.1.10] #[copyright "2024"] #[titledesc {tomlish toml parser}] [comment {-- Name section and table of contents description --}] #[moddesc {tomlish}] [comment {-- Description at end of page heading --}] @@ -385,6 +385,45 @@ namespace eval tomlish { } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::tomlish::to_dict + @cmd -name "tomlish::to_dict"\ + -summary\ + "Convert a tomlish structure to a Tcl dict with typed leaf values"\ + -help\ + "Converts tomlish (the tagged-list representation produced + by tomlish::from_toml) to a Tcl dict datastructure. + + Toml tables map to nested dict keys. Each leaf value is a + two-element dict of the form {type value } + where is a toml/tomlish type such as INT, FLOAT, + BOOL, STRING, LITERAL, MULTISTRING, MULTILITERAL, DATETIME + or ARRAY (an ARRAY value is a list of typed elements). + Escape sequences in quoted strings are substituted during + this conversion. + + Whitespace and comments are not represented in the result, + so a dict alone cannot round-trip formatting - use + tomlish::update_tomlish_from_dict to write dict values back + into an existing tomlish structure when preservation + matters. + + Toml validity rules that require whole-document knowledge + (e.g 'You cannot define any key or table more than once') + are enforced here and raise errors. + + Returns the dict, or with returnextra true a dict with keys + 'datastructure' (the converted dict) and 'tablenames_info' + (per-tablename creation/definition metadata)." + @leaders + tomlish -type list -optional 0 -help\ + "tomlish tagged list (e.g from tomlish::from_toml)" + returnextra -type boolean -optional 1 -default 0 -help\ + "when true, return a dict of keys 'datastructure' and + 'tablenames_info' instead of the datastructure alone" + }] + } proc to_dict {tomlish {returnextra 0}} { tomlish::dict::from_tomlish $tomlish $returnextra } @@ -708,6 +747,31 @@ namespace eval tomlish { } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::tomlish::from_dict + @cmd -name "tomlish::from_dict"\ + -summary\ + "Convert a dict with typed leaf values to a tomlish structure"\ + -help\ + "Converts a Tcl dict whose leaf values are typed + ({type value } - the form produced by + tomlish::to_dict) into a new tomlish tagged-list structure, + which tomlish::to_toml can serialise to toml text. + + The dict must be a full typed representation - plain + untyped leaf values are not accepted. As a dict carries no + whitespace/comment information, the generated tomlish (and + any toml produced from it) uses generated formatting; to + preserve the formatting of an existing document, write + values back with tomlish::update_tomlish_from_dict instead. + + Returns the tomlish list." + @leaders + d -type dict -optional 0 -help\ + "dict with typed leaf values (e.g from tomlish::to_dict)" + }] + } proc from_dict {d} { #consider: # t1={a=1,b=2} @@ -906,6 +970,33 @@ namespace eval tomlish { # For this reason, we also do absolutely no line-ending transformations based on platform. # All line-endings are maintained as is, and even a file with mixed lf crlf line-endings will be correctly interpreted and can be 'roundtripped' + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::tomlish::from_toml + @cmd -name "tomlish::from_toml"\ + -summary\ + "Parse toml text into a tomlish tagged-list structure"\ + -help\ + "Parses toml source text into 'tomlish' - the intermediate + tagged-list representation used by the tomlish package. + + tomlish is whitespace and comment preserving: serialising + the result with tomlish::to_toml reproduces the input byte + for byte (lossless round-trip). No escape sequences in + quoted strings are processed at this stage and no + line-ending transformations are performed - that occurs in + datastructure conversions such as tomlish::to_dict. + + Returns the tomlish list: first element is the tag TOMLISH, + remaining elements are tagged records such as TABLE, + TABLEARRAY, DOTTEDKEY, WS, COMMENT, NEWLINE. + Raises an error for invalid toml." + @values -min 1 -max -1 + toml -type string -optional 0 -multiple 1 -help\ + "toml source text. Multiple values are joined with newline + characters before parsing." + }] + } proc from_toml {args} { namespace upvar ::tomlish::parse s s @@ -1764,6 +1855,34 @@ namespace eval tomlish { # updating from a subset dict (reduces processing - and more flexible to supply only paths to leaves requiring update?) # #todo - allow adding extra leaves e.g keys in tables,tablearrays, itables, arrays + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::tomlish::update_tomlish_from_dict + @cmd -name "tomlish::update_tomlish_from_dict"\ + -summary\ + "Update leaf values in a tomlish structure from a typed dict, preserving formatting"\ + -help\ + "Merges values from dict d into an existing tomlish + structure and returns the updated tomlish, in which + whitespace, comments and key ordering are preserved. + + This is the formatting-preserving write path: parse a + document with tomlish::from_toml, convert with + tomlish::to_dict, modify values in the dict, apply them + with this command, then serialise with tomlish::to_toml. + + d must be a full typed representation of the datastructure + (as produced by tomlish::to_dict). The initial + implementation updates leaf values only - adding or pruning + keys/branches is not yet supported." + @leaders + tomlish -type list -optional 0 -help\ + "existing tomlish tagged list (e.g from tomlish::from_toml)" + d -type dict -optional 0 -help\ + "full typed-dict representation carrying the updated leaf + values" + }] + } proc update_tomlish_from_dict {tomlish d} { set returnextra true #validate supplied tomlish and keep tablenames_info (review - validate structure only - allow invalid values to be overwritten from dict?) @@ -2441,6 +2560,34 @@ namespace eval tomlish::encode { #fish toml from tomlish #(encode tomlish as toml) +namespace eval ::tomlish::argdoc { + lappend PUNKARGS [list { + @id -id ::tomlish::to_toml + @cmd -name "tomlish::to_toml"\ + -summary\ + "Serialise a tomlish structure to toml text"\ + -help\ + "Encodes tomlish (the tagged-list representation produced by + tomlish::from_toml or tomlish::from_dict) as toml text. + + For tomlish obtained from tomlish::from_toml this reproduces + the original document byte for byte, including whitespace and + comments (lossless round-trip). + + Validation here is structural only - toml validity rules that + need whole-document knowledge (e.g duplicate keys/tables) are + not detected; they are the role of the dict conversion pair + tomlish::to_dict / tomlish::from_dict. + + tomlish::to_toml is an alias of tomlish::encode::tomlish. + Returns the toml text." + @leaders + list -type list -optional 0 -help\ + "tomlish tagged list" + context -type string -optional 1 -default "" -help\ + "internal recursion context tag - omit in normal use" + }] +} interp alias {} tomlish::to_toml {} tomlish::encode::tomlish # @@ -9408,12 +9555,48 @@ namespace eval tomlish::system { #[list_end] [comment {--- end definitions namespace tomlish::system ---}] } +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + #documentation-only PUNKARGS registration - discovered lazily if/when punk::args is loaded; + #adds no punk::args dependency to the tomlish library itself. + lappend ::punk::args::register::NAMESPACES ::tomlish::argdoc +} + # if {[info exists ::argc] && $::argc > 0} {} ;#not a valid way to test if main script -if {[tomlish::system::is_main_script]} { - #puts stderr "argc: $::argc args: $::argv" - set arglist $::argv +namespace eval tomlish { + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::tomlish::cmdline_main + @cmd -name "tomlish::cmdline_main"\ + -summary\ + "Run the tomlish command-line application on an argument list"\ + -help\ + "Explicit entry point for the tomlish command-line app + (usage display and -app dispatch to the tomlish::app::* + applications such as decode_to_typedjson, + encode_from_typedjson, test). + + Called automatically with \$::argv when the tomlish module + file is the main script (tclsh tomlish.tcl ...). Launchers + such as a wrapped tomlish executable's app package must + call this explicitly after package require tomlish - since + the tomlish::system::is_main_script gate (1.1.8) the app + no longer runs as a load-time side effect of ::argc/::argv + being set. + + Zeroes the global ::argv/::argc before loading dependent + packages (argument hygiene) and terminates the process via + exit on every path: 0 for success/help, 1 for usage or + application errors." + @leaders + arglist -type list -optional 0 -help\ + "command-line argument list (typically \$::argv)" + }] + } +} +proc ::tomlish::cmdline_main {arglist} { # -------------- #make sure any dependant packages that are sourced don't get any commandline args set ::argv {} @@ -9476,11 +9659,16 @@ if {[tomlish::system::is_main_script]} { } } +if {[tomlish::system::is_main_script]} { + #puts stderr "argc: $::argc args: $::argv" + tomlish::cmdline_main $::argv +} + ## Ready package provide tomlish [namespace eval tomlish { variable pkg tomlish variable version - set version 1.1.8 + set version 1.1.10 }] return diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.2.0.tm similarity index 94% rename from src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.1.tm rename to src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.2.0.tm index 8fa2cac2..a8086722 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.2.0.tm @@ -8411,38 +8411,507 @@ namespace eval punk { } puts -nonewline stdout \n } - #return list of {chan chunk} elements - namespace eval argdoc { + #punk::help topic registry + #Each registered topic has: + # - a handler proc ::punk::helptopic:: taking a context dict plus any extra words, + # returning the topic's help content as a list of {channel text} chunks + # - a punk::args definition with id ::punk::helptopic:: so that 'i help ' shows documented usage + #Registering a topic (re)generates the ::punk::help and ::punk::help_chunks punk::args definitions, + #so the documented topic choices always match the registry. + #The 'overview' handler is not a registered topic - it is what a plain 'help' displays. + #Unregistered topic words fall through to basic command-info lookup (see ::punk::help_chunks). + namespace eval helptopic { + variable topics [dict create] + + tcl::namespace::import ::punk::ansi::a ::punk::ansi::a+ + + proc register {topic aliases summary} { + variable topics + if {![llength [info commands [namespace current]::$topic]]} { + error "punk::helptopic::register - no handler proc '[namespace current]::$topic' exists for topic '$topic'" + } + dict set topics $topic [dict create aliases $aliases summary $summary] + define_docs + return + } + + #return the canonical topic name for a topic word or alias - empty string if not a registered topic + proc resolve {word} { + variable topics + dict for {topic tinfo} $topics { + if {$word eq $topic || $word in [dict get $tinfo aliases]} { + return $topic + } + } + return "" + } + + #standard command-info table as used by the help overview blocks + proc table_block {frametype title rows {minwidth 80}} { + set t [textblock::class::table new -minwidth $minwidth -show_seps 0] + $t configure -frametype $frametype + foreach row $rows { + $t add_row $row + } + $t configure_column 0 -minwidth [expr {[$t column_datawidth 0] + 2}] + $t configure_column 1 -minwidth [expr {[$t column_datawidth 1] + 1}] + $t configure -title $title + set text [$t print] + $t destroy + return $text + } + + #(re)generate the punk::args definitions for ::punk::help and ::punk::help_chunks from the registry + #so that 'i help' shows a documented topic table matching the registered topics. + proc define_docs {} { + variable topics + set choices [list] + set choiceinfo [dict create] + set choicelabels [dict create] + dict for {topic tinfo} $topics { + foreach name [list $topic {*}[dict get $tinfo aliases]] { + lappend choices $name + dict set choiceinfo $name [list [list doctype punkargs] [list subhelp [namespace current]::$topic]] + dict set choicelabels $name [dict get $tinfo summary] + } + } + set basehelp {Help system for the punk shell. + With no arguments - an overview of some key shell commands is displayed. + When the first argument is a recognised topic - help for that topic is displayed. + ('help topics' lists the available topics) + Anything else is treated as a command name - basic command info (type and + synopsis) is shown for a resolvable command, or the resolved path for an + external executable.} + set topichelp {Help topic, or command words for basic command info. (topics must match exactly - no prefix matching)} + set specs [list] + lappend specs ::punk::help help "Punk shell help system." "" + lappend specs ::punk::help_chunks punk::help_chunks "Punk shell help system - content as {channel text} chunks." "\n\nhelp_chunks returns the help content as a list of {channel text} chunks rather than emitting it." + foreach {id name summary extra} $specs { + set def "" + append def "@id -id $id" \n + append def "@cmd -name $name -summary \"$summary\" -help \"$basehelp$extra\"" \n + append def "@leaders -min 0 -max -1" \n + append def "topic -optional 1 -multiple 1 -type string -choiceprefix 0 -choicerestricted 0 -choices {$choices} -choiceinfo {$choiceinfo} -choicelabels {$choicelabels} -help \"$topichelp\"" \n + append def "@values -min 0 -max 0" + if {[punk::args::id_exists $id]} { + #quiet undefine - redefinition on registry change is expected, not noteworthy + punk::args::undefine $id 1 + } + punk::args::define $def + } + } + + #The no-topic overview of key shell commands (what a plain 'help' displays) + proc overview {context args} { + set frametype [dict get $context frametype] + set I [dict get $context I] + set NI [dict get $context NI] + set chunks [list] + + set title "[a+ brightgreen] Filesystem navigation: " + set cmdinfo [list] + lappend cmdinfo [list ./ "?${I}glob${NI}?" "view/change dir, list dirs."] + lappend cmdinfo [list .// "?${I}glob${NI}?" "view/change dir, list dirs and files"] + lappend cmdinfo [list ../ "?${I}path${NI}" "go up one dir, then to path if given"] + 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)"] + lappend chunks [list stdout [table_block $frametype $title $cmdinfo]\n] + + 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 "newns" "${I}ns${NI}" "make child namespace and switch to it"] + lappend chunks [list stdout [table_block $frametype $title $cmdinfo]\n] + + set title "[a+ brightgreen] Command help: " + set cmdinfo [list] + lappend cmdinfo [list i "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show usage for a command or ensemble subcommand"] + lappend cmdinfo [list s "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show synopsis for a command or ensemble subcommand"] + lappend cmdinfo [list eg "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show example from manpage"] + lappend cmdinfo [list corp "${I}proc${NI}" "View proc body and arguments with basic highlighting"] + lappend chunks [list stdout [table_block $frametype $title $cmdinfo]\n] + + set title "[a+ brightgreen] Miscellaneous: " + #todo - load from source code annotation? + set cmdinfo [list] + lappend cmdinfo [list dev "?${I}subcommand${NI}?" "(ensemble command to make new projects/modules and\n to generate docs)"] + lappend cmdinfo [list a? "?${I}subcommand${NI}...?" "view ANSI colours\n e.g a? web\n or individual code samples/diagnostics\n e.g a? red bold\n e.g a? underline web-orange Term-purple3"] + lappend cmdinfo [list a+ "?${I}colourcode${NI}...?" "Return ANSI codes\n e.g puts \"\[a+ purple\]purple\[a+ Green\]purple on green\[a\]\"\n [a+ purple]purple[a+ Green]purple on green[a] "] + lappend cmdinfo [list a "?${I}colourcode${NI}...?" "Return ANSI codes (with leading reset)\n e.g puts \"\[a+ purple\]purple\[a Green\]normal on green\[a\]\"\n [a+ purple]purple[a Green]normal on green[a] "] + lappend chunks [list stdout [table_block $frametype $title $cmdinfo]] + + return $chunks + } + punk::args::define { - @id -id ::punk::help_chunks - @cmd -name "punk::help_chunks"\ - -summary\ - ""\ - -help\ - "" - @opts - -- -type none - @values -min 0 -max -1 - arg -type any -optional 1 -multiple 1 + @id -id ::punk::helptopic::topics + @cmd -name "help topics" -summary "List help topics." -help "Show the table of topics known to the help system, including registered aliases for each topic." + @values -min 0 -max 0 + } + proc topics {context args} { + variable topics + set frametype [dict get $context frametype] + set t [textblock::class::table new -show_seps 0] + $t configure -frametype $frametype + $t add_column -headers [list "Topic"] + $t add_column + dict for {topic tinfo} $topics { + $t add_row [list [join [list $topic {*}[dict get $tinfo aliases]] |] [dict get $tinfo summary]] + } + $t add_row [list "*" "Look up as a command or external executable"] + $t configure_column 0 -minwidth [expr {[$t column_datawidth 0] + 4}] + set text \n[$t print] + $t destroy + return [list [list stdout $text]] + } + + punk::args::define { + @id -id ::punk::helptopic::tcl + @cmd -name "help tcl" -summary "Tcl version warnings." -help "Show the running Tcl patchlevel and build-info, with warnings for known Tcl bugs affecting this interpreter (as detected by the punk::lib::check::has_tclbug_* checks)." + @values -min 0 -max 0 + } + proc tcl {context args} { + set chunks [list] + set warningblock "" + set text "Tcl Patchlevel: [info patchlevel]" + catch { + append text \n "Tcl build-info: [::tcl::build-info]" + } + #generate warningblocks for each triggered Tcl bug in namespace ::punk::lib::check + set bugcheck_procs [info procs ::punk::lib::check::has_tclbug*] + foreach bp $bugcheck_procs { + set buginfo [$bp] + if {[dict get $buginfo bug]} { + set level unknown + if {[dict exists $buginfo level]} { + set level [dict get $buginfo level] + } + switch -- $level { + minor {set highlight [punk::ansi::a+ cyan]} + medium {set highlight [punk::ansi::a+ yellow]} + major {set highlight [punk::ansi::a+ red bold]} + default {set highlight ""} + } + append warningblock \n $highlight "warning level: $level $bp triggered." + if {[dict exists $buginfo description]} { + set indent " " + append warningblock \n "[punk::lib::indent [dict get $buginfo description] $indent]" + } + if {[dict exists $buginfo bugref] && [dict get $buginfo bugref] ne ""} { + set bugref [dict get $buginfo bugref] + append warningblock \n "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/$bugref]" + } + append warningblock [a] + } + } + + if {[catch {lsearch -stride 2 {a b} b}]} { + #has_tclbug_lsearch_strideallinline will have reported bug false because it couldn't test it. + set indent " " + append warningblock \n "[a+ web-red]warning: lsearch does not seem to support -stride option" \n + append warningblock "${indent}(Consider upgrading to a late release of tcl 8.6 or tcl 9+ )" \n + append warningblock [a] + } + lappend chunks [list stdout $text] + lappend chunks [list stderr $warningblock] + return $chunks + } + + punk::args::define { + @id -id ::punk::helptopic::env + @cmd -name "help env" -summary "punkshell environment vars." -help "Show punk-related and other relevant environment variables with their current values." + @values -min 0 -max 0 + } + proc env {context args} { + if {[catch {package require punk::config} errM]} { + return [list [list stderr "help env: punk::config package not available - no environment variable info ($errM)\n"]] + } + if {![info exists ::punk::config::punk_env_vars_config] || ![info exists ::punk::config::other_env_vars_config]} { + #punk::config::init has side effects (config dir/file creation) - don't trigger it just for help + return [list [list stderr "help env: punk::config not initialised - no environment variable info\n"]] + } + set frametype [dict get $context frametype] + set linesep [string repeat - 76] + set chunks [list] + set text "" + #todo - move to punk::config? + upvar ::punk::config::punk_env_vars_config punkenv_config + upvar ::punk::config::other_env_vars_config otherenv_config + + set known_punk [dict keys $punkenv_config] + set known_other [dict keys $otherenv_config] + append text \n + set usetable 1 + if {$usetable} { + set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] + $t configure -frametype $frametype + if {"windows" eq $::tcl_platform(platform)} { + #If any env vars have been set to empty string - this is considered a deletion of the variable on windows. + #The Tcl ::env array is linked to the underlying process view of the environment + #- but info exists ::env(var) can misreport as true if it has been deleted by setting to empty string rather than using unset. + #an 'array get' will resynchronise. + #Even if an env variable didn't exist before - setting it to empty string can get it to this inconsistent state. + array get ::env + } + #do an array read on ::env + foreach {v vinfo} $punkenv_config { + if {[info exists ::env($v)]} { + set c2 [set ::env($v)] + } else { + set c2 "(NOT SET)" + } + set help "" + if {[dict exists $vinfo help]} { + set help [dict get $vinfo help] + } + $t add_row [list $v $c2 $help] + } + $t configure_column 0 -headers [list "Punk environment vars"] + $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} + + set punktable [$t print] + $t destroy + + set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] + $t configure -frametype $frametype + foreach {v vinfo} $otherenv_config { + if {[info exists ::env($v)]} { + set env_val [set ::env($v)] + if {[string match "*_TM_PATH" $v]} { + set entries [split $env_val $::tcl_platform(pathSeparator)] + set c2 [join $entries \n] + } else { + set c2 $::env($v) + } + } else { + set c2 "(NOT SET)" + } + $t add_row [list $v $c2] + } + $t configure_column 0 -headers [list "Other environment vars"] + $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} + + set othertable [$t print] + $t destroy + #append text [textblock::join -- $punktable " " $othertable]\n + append text $punktable\n$othertable\n + } else { + + append text $linesep\n + append text "punk environment vars:\n" + append text $linesep\n + set col1 [string repeat " " 25] + set col2 [string repeat " " 50] + foreach v $known_punk { + set c1 [overtype::left $col1 $v] + if {[info exists ::env($v)]} { + set c2 [overtype::left $col2 [set ::env($v)]] + } else { + set c2 [overtype::right $col2 "(NOT SET)"] + } + append text "$c1 $c2\n" + } + append text $linesep\n + } + + lappend chunks [list stdout $text] + return $chunks + } + + punk::args::define { + @id -id ::punk::helptopic::console + @cmd -name "help console" -summary "Console behaviour tests and warnings." -help "Run some console/terminal behaviour tests (control string hiding, grapheme cluster support, cursor position query timing) and report warnings. Requires a responsive interactive console." + @values -min 0 -max 0 + } + proc console {context args} { + set chunks [list] + set warningblock "" + set term_env_vars {TERM TERM_PROGRAM TERM_PROGRAM_VERSION COLORTERM} + set term_dict [dict create] + foreach e $term_env_vars { + if {[info exists ::env($e)]} { + dict set term_dict $e [set ::env($e)] + } else { + dict set term_dict $e "(NOT SET)" + } + } + set text "Terminal environment variables:\n" + append text [punk::lib::showdict $term_dict] \n + lappend chunks [list stdout $text] + set text "" + set indent [string repeat " " [string length "WARNING: "]] + + 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 { + + if {![catch {punk::console::class_info} console_class_info]} { + set text "Terminal class info (from device secondary attributes query to terminal):\n" + append text [punk::lib::showdict $console_class_info] \n + } else { + set text "Unable to query terminal class info - err:$console_class_info\n" + } + lappend chunks [list stdout $text] + + 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" + } + } + 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" + } + + 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" + } + + + 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 posn [punk::console::get_cursor_pos] ;#warmup call - and test if works + if {$posn eq ""} { + append warningblock \n "WARNING: terminal doesn't respond to cursor position query - may cause display bugs in some cases." + } else { + set timeresult [timerate {set cpos [punk::console::get_cursor_pos]}] + lassign [split $cpos {;}] row col + if {![string is integer -strict $row] || ![string is integer -strict $col]} { + append warningblock \n "WARNING: terminal returns non-integer values for cursor position query - may cause display bugs in some cases. got row:'$row' col:'$col'" + } else { + set micros [lindex $timeresult 0] + if {$micros > 2000} { + append warningblock \n "WARNING: terminal cursor position query is very slow ($micros microseconds - expect < 2000us )" + append warningblock \n $indent "- may cause display lag/bugs in some cases." + } else { + if {$micros > 1000} { + set text "\n[a+ yellow]Terminal cursor position query test passed." + append text \n $indent "Response time: ${micros} microseconds (OK, good would be <= 1000us).[a]" + + } else { + set text "[a+ green]Terminal cursor position query test passed." + append text \n $indent "Response time: ${micros} microseconds (GOOD).[a]" + } + lappend chunks [list stdout $text] + } + } + } + + + if {![string length $warningblock]} { + set text "[a+ green]No terminal warnings[a]\n" + lappend chunks [list stdout $text] + } else { + set mode [punk::console::mode] + if {$mode eq "line"} { + append warningblock \n "Terminal appears to be in line mode. Consider switching to raw mode and re-testing (command: punk::console::mode raw)." + } + } + puts stdout [punk::ansi::move_back 200] ;#hack for some horizontal position bugs where the above tests can leave the cursor in the wrong place for the next output. + #200 is arbitrary large number to move back enough to get to start of line. + } + lappend chunks [list stderr $warningblock] + return $chunks } + + register topics {help} "List help topics" + register tcl {} "Tcl version warnings" + register env {environment} "punkshell environment vars" + register console {term terminal} "Some console behaviour tests and warnings" } + + #return list of {chan chunk} elements proc help_chunks {args} { - set argd [punk::args::parse $args withid ::punk::help_chunks] + set argd [punk::args::parse $args withid ::punk::help] lassign [dict values $argd] leaders opts values received - if {[dict exists $values arg]} { - set topicparts [dict get $values arg] + if {[dict exists $leaders topic]} { + set topicparts [dict get $leaders topic] } else { set topicparts [list ""] } - #set topic [lindex $args end] - #set argopts [lrange $args 0 end-1] - set chunks [list] - set linesep [string repeat - 76] - - set warningblock "" set I [punk::ansi::a+ italic] set NI [punk::ansi::a+ noitalic] @@ -8471,6 +8940,8 @@ namespace eval punk { } + set context [dict create cols $cols rows $rows frametype $frametype I $I NI $NI] + # ------------------------------------------------------- set logoblock "" if {[catch { @@ -8483,473 +8954,54 @@ namespace eval punk { set title "[a+ brightgreen] Help System: " set cmdinfo [list] lappend cmdinfo [list help "?${I}topic${NI}?" "This help.\nTo see available subitems type:\nhelp topics\n\nFor an unrecognised ${I}topic${NI}\nhelp will look for basic\ninfo for it as a command.\n"] - set t [textblock::class::table new -minwidth 51 -show_seps 0] - $t configure -frametype $frametype - foreach row $cmdinfo { - $t add_row $row - } - set width_0 [$t column_datawidth 0] - $t configure_column 0 -minwidth [expr {$width_0 + 2}] - set width_1 [$t column_datawidth 1] - $t configure_column 1 -minwidth [expr {$width_1 + 1}] - $t configure -title $title - set text [$t print] + set text [helptopic::table_block $frametype $title $cmdinfo 51] set introblock [textblock::join -- $logoblock $text] lappend chunks [list stdout $introblock\n] # ------------------------------------------------------- - switch -- [lindex $topicparts 0] { - "" { - - # ------------------------------------------------------- - set title "[a+ brightgreen] Filesystem navigation: " - set cmdinfo [list] - lappend cmdinfo [list ./ "?${I}glob${NI}?" "view/change dir, list dirs."] - lappend cmdinfo [list .// "?${I}glob${NI}?" "view/change dir, list dirs and files"] - lappend cmdinfo [list ../ "?${I}path${NI}" "go up one dir, then to path if given"] - 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] - $t configure -frametype $frametype - foreach row $cmdinfo { - $t add_row $row - } - set width_0 [$t column_datawidth 0] - $t configure_column 0 -minwidth [expr {$width_0 + 2}] - set width_1 [$t column_datawidth 1] - $t configure_column 1 -minwidth [expr {$width_1 + 1}] - $t configure -title $title - - set text "" - append text [$t print] - lappend chunks [list stdout $text\n] - # ------------------------------------------------------- - - - # ------------------------------------------------------- - 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 "newns" "${I}ns${NI}" "make child namespace and switch to it"] - set t [textblock::class::table new -minwidth 80 -show_seps 0] - $t configure -frametype $frametype - foreach row $cmdinfo { - $t add_row $row - } - set width_0 [$t column_datawidth 0] - $t configure_column 0 -minwidth [expr {$width_0 + 2}] - set width_1 [$t column_datawidth 1] - $t configure_column 1 -minwidth [expr {$width_1 + 1}] - $t configure -title $title - - set text "" - append text [$t print] - lappend chunks [list stdout $text\n] - # ------------------------------------------------------- - - # ------------------------------------------------------- - set title "[a+ brightgreen] Command help: " - set cmdinfo [list] - lappend cmdinfo [list i "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show usage for a command or ensemble subcommand"] - lappend cmdinfo [list s "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show synopsis for a command or ensemble subcommand"] - lappend cmdinfo [list eg "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show example from manpage"] - lappend cmdinfo [list corp "${I}proc${NI}" "View proc body and arguments with basic highlighting"] - set t [textblock::class::table new -minwidth 80 -show_seps 0] - $t configure -frametype $frametype - foreach row $cmdinfo { - $t add_row $row - } - set width_0 [$t column_datawidth 0] - $t configure_column 0 -minwidth [expr {$width_0 + 2}] - set width_1 [$t column_datawidth 1] - $t configure_column 1 -minwidth [expr {$width_1 + 1}] - $t configure -title $title - - set text "" - append text [$t print] - lappend chunks [list stdout $text\n] - # ------------------------------------------------------- - - - set title "[a+ brightgreen] Miscellaneous: " - #todo - load from source code annotation? - set cmdinfo [list] - lappend cmdinfo [list dev "?${I}subcommand${NI}?" "(ensemble command to make new projects/modules and\n to generate docs)"] - lappend cmdinfo [list a? "?${I}subcommand${NI}...?" "view ANSI colours\n e.g a? web\n or individual code samples/diagnostics\n e.g a? red bold\n e.g a? underline web-orange Term-purple3"] - lappend cmdinfo [list a+ "?${I}colourcode${NI}...?" "Return ANSI codes\n e.g puts \"\[a+ purple\]purple\[a+ Green\]purple on green\[a\]\"\n [a+ purple]purple[a+ Green]purple on green[a] "] - lappend cmdinfo [list a "?${I}colourcode${NI}...?" "Return ANSI codes (with leading reset)\n e.g puts \"\[a+ purple\]purple\[a Green\]normal on green\[a\]\"\n [a+ purple]purple[a Green]normal on green[a] "] - - set t [textblock::class::table new -minwidth 80 -show_seps 0] - $t configure -frametype $frametype - foreach row $cmdinfo { - $t add_row $row - } - set width_0 [$t column_datawidth 0] - $t configure_column 0 -minwidth [expr {$width_0 + 2}] - set width_1 [$t column_datawidth 1] - $t configure_column 1 -minwidth [expr {$width_1 + 1}] - $t configure -title $title - - set text "" - append text [$t print] - lappend chunks [list stdout $text] - # ------------------------------------------------------- - - } - tcl { - set text "Tcl Patchlevel: [info patchlevel]" - catch { - append text \n "Tcl build-info: [::tcl::build-info]" - } - #generate warningblocks for each triggered Tcl bug in namespace ::punk::lib::check - set bugcheck_procs [info procs ::punk::lib::check::has_tclbug*] - foreach bp $bugcheck_procs { - set buginfo [$bp] - if {[dict get $buginfo bug]} { - set level unknown - if {[dict exists $buginfo level]} { - set level [dict get $buginfo level] - } - switch -- $level { - minor {set highlight [punk::ansi::a+ cyan]} - medium {set highlight [punk::ansi::a+ yellow]} - major {set highlight [punk::ansi::a+ red bold]} - default {set highlight ""} - } - append warningblock \n $highlight "warning level: $level $bp triggered." - if {[dict exists $buginfo description]} { - set indent " " - append warningblock \n "[punk::lib::indent [dict get $buginfo description] $indent]" - } - if {[dict exists $buginfo bugref] && [dict get $buginfo bugref] ne ""} { - set bugref [dict get $buginfo bugref] - append warningblock \n "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/$bugref]" - } - append warningblock [a] - } - } - - if {[catch {lsearch -stride 2 {a b} b}]} { - #has_tclbug_lsearch_strideallinline will have reported bug false because it couldn't test it. - set indent " " - append warningblock \n "[a+ web-red]warning: lsearch does not seem to support -stride option" \n - append warningblock "${indent}(Consider upgrading to a late release of tcl 8.6 or tcl 9+ )" \n - append warningblock [a] - } - lappend chunks [list stdout $text] - } - env - environment { - set text "" - #todo - move to punk::config? - upvar ::punk::config::punk_env_vars_config punkenv_config - upvar ::punk::config::other_env_vars_config otherenv_config - - set known_punk [dict keys $punkenv_config] - set known_other [dict keys $otherenv_config] - append text \n - set usetable 1 - if {$usetable} { - set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] - $t configure -frametype $frametype - if {"windows" eq $::tcl_platform(platform)} { - #If any env vars have been set to empty string - this is considered a deletion of the variable on windows. - #The Tcl ::env array is linked to the underlying process view of the environment - #- but info exists ::env(var) can misreport as true if it has been deleted by setting to empty string rather than using unset. - #an 'array get' will resynchronise. - #Even if an env variable didn't exist before - setting it to empty string can get it to this inconsistent state. - array get ::env - } - #do an array read on ::env - foreach {v vinfo} $punkenv_config { - if {[info exists ::env($v)]} { - set c2 [set ::env($v)] - } else { - set c2 "(NOT SET)" - } - set help "" - if {[dict exists $vinfo help]} { - set help [dict get $vinfo help] - } - $t add_row [list $v $c2 $help] - } - $t configure_column 0 -headers [list "Punk environment vars"] - $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} - - set punktable [$t print] - $t destroy - - set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] - $t configure -frametype $frametype - foreach {v vinfo} $otherenv_config { - if {[info exists ::env($v)]} { - set env_val [set ::env($v)] - if {[string match "*_TM_PATH" $v]} { - set entries [split $env_val $::tcl_platform(pathSeparator)] - set c2 [join $entries \n] - } else { - set c2 $::env($v) - } - } else { - set c2 "(NOT SET)" - } - $t add_row [list $v $c2] - } - $t configure_column 0 -headers [list "Other environment vars"] - $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} - - set othertable [$t print] - $t destroy - #append text [textblock::join -- $punktable " " $othertable]\n - append text $punktable\n$othertable\n + set word0 [lindex $topicparts 0] + set topic [helptopic::resolve $word0] + if {$word0 eq ""} { + #no topic supplied - overview of key shell commands + lappend chunks {*}[helptopic::overview $context {*}[lrange $topicparts 1 end]] + } elseif {$topic ne ""} { + lappend chunks {*}[helptopic::$topic $context {*}[lrange $topicparts 1 end]] + } else { + #not a registered topic - fall through to basic command info lookup + set text "" + set cinfo [uplevel 1 [list ::punk::ns::cmdwhich [lindex $topicparts 0]]] + set wtype [dict get $cinfo whichtype] + if {$wtype eq "notfound"} { + set externalinfo [auto_execok [lindex $topicparts 0]] + if {[string length $externalinfo]} { + set text "$topicparts" + append text \n "Base type: External command" + append text \n "$externalinfo [lrange $topicparts 1 end]" } else { - - append text $linesep\n - append text "punk environment vars:\n" - append text $linesep\n - set col1 [string repeat " " 25] - set col2 [string repeat " " 50] - foreach v $known_punk { - set c1 [overtype::left $col1 $v] - if {[info exists ::env($v)]} { - set c2 [overtype::left $col2 [set ::env($v)]] - } else { - set c2 [overtype::right $col2 "(NOT SET)"] - } - append text "$c1 $c2\n" - } - append text $linesep\n + set text "$topicparts\n" + append text "No matching internal or external command found" } - - lappend chunks [list stdout $text] - } - console - term - terminal { - set term_env_vars {TERM TERM_PROGRAM TERM_PROGRAM_VERSION COLORTERM} - set term_dict [dict create] - foreach e $term_env_vars { - if {[info exists ::env($e)]} { - dict set term_dict $e [set ::env($e)] - } else { - dict set term_dict $e "(NOT SET)" - } - } - set text "Terminal environment variables:\n" - append text [punk::lib::showdict $term_dict] \n - lappend chunks [list stdout $text] - set text "" - set indent [string repeat " " [string length "WARNING: "]] - - 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 { - - if {![catch {punk::console::class_info} console_class_info]} { - set text "Terminal class info (from device secondary attributes query to terminal):\n" - append text [punk::lib::showdict $console_class_info] \n - } else { - set text "Unable to query terminal class info - err:$console_class_info\n" - } - lappend chunks [list stdout $text] - - 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" - } - } - 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" - } - - 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" - } - - - 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 posn [punk::console::get_cursor_pos] ;#warmup call - and test if works - if {$posn eq ""} { - append warningblock \n "WARNING: terminal doesn't respond to cursor position query - may cause display bugs in some cases." - } else { - set timeresult [timerate {set cpos [punk::console::get_cursor_pos]}] - lassign [split $cpos {;}] row col - if {![string is integer -strict $row] || ![string is integer -strict $col]} { - append warningblock \n "WARNING: terminal returns non-integer values for cursor position query - may cause display bugs in some cases. got row:'$row' col:'$col'" - } else { - set micros [lindex $timeresult 0] - if {$micros > 2000} { - append warningblock \n "WARNING: terminal cursor position query is very slow ($micros microseconds - expect < 2000us )" - append warningblock \n $indent "- may cause display lag/bugs in some cases." - } else { - if {$micros > 1000} { - set text "\n[a+ yellow]Terminal cursor position query test passed." - append text \n $indent "Response time: ${micros} microseconds (OK, good would be <= 1000us).[a]" - - } else { - set text "[a+ green]Terminal cursor position query test passed." - append text \n $indent "Response time: ${micros} microseconds (GOOD).[a]" - } - lappend chunks [list stdout $text] - } - } - } - - - if {![string length $warningblock]} { - set text "[a+ green]No terminal warnings[a]\n" - lappend chunks [list stdout $text] + } else { + set text "[dict get $cinfo which] [lrange $topicparts 1 end]" + append text \n "Base type: $wtype" + set synopsis [uplevel 1 [list ::punk::ns::synopsis {*}$topicparts]] + set synshow "" + foreach sline [split $synopsis \n] { + if {[regexp {\s*#.*} $sline]} { + append synshow [punk::ansi::a+ bold term-darkgreen Term-white]$sline[punk::ansi::a] \n } else { - set mode [punk::console::mode] - if {$mode eq "line"} { - append warningblock \n "Terminal appears to be in line mode. Consider switching to raw mode and re-testing (command: punk::console::mode raw)." - } + append synshow $sline \n } - puts stdout [punk::ansi::move_back 200] ;#hack for some horizontal position bugs where the above tests can leave the cursor in the wrong place for the next output. - #200 is arbitrary large number to move back enough to get to start of line. - } - } - topics - help { - set text "" - set topics [dict create {*}{ - "topics|help" "List help topics" - "tcl" "Tcl version warnings" - "env|environment" "punkshell environment vars" - "console|terminal" "Some console behaviour tests and warnings" - "*" "Try to find help on the topic as a command or external executable" - }] - - set t [textblock::class::table new -show_seps 0] - $t configure -frametype $frametype - $t add_column -headers [list "Topic"] - $t add_column - foreach {k v} $topics { - $t add_row [list $k $v] } - set widest0 [$t column_datawidth 0] - $t configure_column 0 -minwidth [expr {$widest0 + 4}] - append text \n [$t print] - - lappend chunks [list stdout $text] - } - default { - set text "" - set cinfo [uplevel 1 [list ::punk::ns::cmdwhich [lindex $topicparts 0]]] - set wtype [dict get $cinfo whichtype] - if {$wtype eq "notfound"} { - set externalinfo [auto_execok [lindex $topicparts 0]] - if {[string length $externalinfo]} { - set text "$topicparts" - append text \n "Base type: External command" - append text \n "$externalinfo [lrange $topicparts 1 end]" - } else { - set text "$topicparts\n" - append text "No matching internal or external command found" - } - } else { - set text "[dict get $cinfo which] [lrange $topicparts 1 end]" - append text \n "Base type: $wtype" - set synopsis [uplevel 1 [list ::punk::ns::synopsis {*}$topicparts]] - set synshow "" - foreach sline [split $synopsis \n] { - if {[regexp {\s*#.*} $sline]} { - append synshow [punk::ansi::a+ bold term-darkgreen Term-white]$sline[punk::ansi::a] \n - } else { - append synshow $sline \n - } - } - if {[string index $synshow end] eq "\n"} { - set synshow [string range $synshow 0 end-1] - } - append text \n $synshow + if {[string index $synshow end] eq "\n"} { + set synshow [string range $synshow 0 end-1] } - lappend chunks [list stdout $text] + append text \n $synshow } + lappend chunks [list stdout $text] } - - - lappend chunks [list stderr $warningblock] return $chunks } proc mode {{raw_or_line query}} { @@ -9298,7 +9350,7 @@ punkcheck::cli set_alias punkcheck package provide punk [namespace eval punk { #FUNCTL variable version - set version 0.1.1 + set version 0.2.0 }] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.3.tm similarity index 99% rename from src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm rename to src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.3.tm index 21ee1c6d..e8b2c3bf 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.3.tm @@ -8,7 +8,7 @@ # (C) 2024 # # @@ Meta Begin -# Application punk::args 0.2.1 +# Application punk::args 0.2.3 # Meta platform tcl # Meta license # @@ Meta End @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_punk::args 0 0.2.1] +#[manpage_begin punkshell_module_punk::args 0 0.2.3] #[copyright "2024"] #[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] #[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] @@ -871,19 +871,46 @@ tcl::namespace::eval punk::args { -choicerestricted Whether values not specified in -choices or -choicegroups are allowed. Defaults to true. + When false, an input that matches no choice - including an + ambiguous prefix, a prefix of a -choiceprefixdenylist entry, + or a -choiceprefixreservelist word - is accepted unchanged as + an ordinary value (subject to -type validation) instead of + raising an error. This passthrough is the pattern for + arguments that mix a known choice set with free-form values + (e.g. a help topic word falling through to command lookup). -choiceprefix This specifies whether unique prefixes are able to be used instead of the complete string. This is calculated using tcl::prefix::match - and will display in the autogenerated usage output. Defaults to true. + A matching prefix is normalized: the parse result contains + the full choice string, never the typed prefix - so callers + switch on canonical choice values only. The usage display + highlights each choice's minimal accepted prefix (a choice + in -choiceprefixdenylist displays fully highlighted - the + whole word is required). -choiceprefixdenylist {} These choices should match exactly a choice entry in one of the settings -choices or -choicegroups. These will still be used in prefix calculation - but the full choice argument must be entered to select the choice. + A shorter prefix of a denied choice is an error when + -choicerestricted is true, and passes through as an ordinary + (non-choice) value when -choicerestricted is false - use this + to keep short words available for other purposes (e.g. with + 'help' denied, h/he/hel remain free-form values). -choiceprefixreservelist {} These choices are additional values used in prefix calculation. The values will not be added to the list of available choices. + A reserved word never matches: entered exactly it is an error + when -choicerestricted is true and passes through when false, + as do any shorter words it shadows into ambiguity. This gives + per-choice control of the minimum accepted prefix by reserving + phantom entries: e.g. -choices {environment} + -choiceprefixreservelist {en} means e/en do not match while + env, envi, ... environment all normalize to environment. + (To require a longer minimum, reserve each shorter form: + reserving {en env} raises the minimum to envi.) -choicegroups {} Generally this would be used instead of -choices to allow usage display of choices grouped by some name (or the empty @@ -6156,7 +6183,7 @@ tcl::namespace::eval punk::args { #puts stderr ">>>_get_dict_can_assign_value idx:$idx v:[lindex $values $idx] consumed:$alloc_count thistype:$thistype" set d [dict create consumed $alloc_count resultlist $resultlist typelist $newtypelist] } else { - puts stderr ">>>_get_dict_can_assign_value NOT alloc_ok: idx:$idx v:[lindex $values $idx] consumed:$alloc_count thistype:$thistype" + #puts stderr ">>>_get_dict_can_assign_value NOT alloc_ok: idx:$idx v:[lindex $values $idx] consumed:$alloc_count thistype:$thistype" set d [dict create consumed 0 resultlist {} typelist $thistype] } #puts ">>>> _get_dict_can_assign_value $d" @@ -9835,7 +9862,10 @@ tcl::namespace::eval punk::args { set argname [dict get $lookup_optset $fullflag] #idents should already have correct parsekey } else { - puts stderr "punk::args::get_dict unable to find $fullflag in $lookup_optset (parsekey:$parsekey) (value_group: $value_group)" + #adhoc option (allowed via "@opts -any|-arbitrary true") - not in lookup_optset. + #argstate/arg_checks were populated for it under its raw supplied name at scan time. + set argname $fullflag + #puts stderr "punk::args::get_dict unable to find $fullflag in $lookup_optset (parsekey:$parsekey) (value_group: $value_group)" } } else { if {[dict exists $lookup_optset $argname_or_ident]} { @@ -9850,7 +9880,15 @@ tcl::namespace::eval punk::args { set parsekey [string trimright [lindex [split $argname |] end] =] } } else { - puts stderr "punk::args::get_dict unable to find $argname_or_ident in $lookup_optset (value_group: $value_group)" + #adhoc option (allowed via "@opts -any|-arbitrary true") - not in lookup_optset. + #argstate/arg_checks were populated for it under its raw supplied name at scan time. + set argname $argname_or_ident + if {$pkoverride ne ""} { + set parsekey $pkoverride + } else { + set parsekey [string trimright [lindex [split $argname |] end] =] + } + #puts stderr "punk::args::get_dict unable to find $argname_or_ident in $lookup_optset (value_group: $value_group)" } } } else { @@ -12357,7 +12395,7 @@ package provide punk::args [tcl::namespace::eval punk::args { tcl::namespace::path {::punk::args::lib ::punk::args::system} variable pkg punk::args variable version - set version 0.2.1 + set version 0.2.3 }] return diff --git a/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.1.tm similarity index 99% rename from src/bootsupport/modules/punk/ns-0.1.0.tm rename to src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.1.tm index ad3cd57e..114d980b 100644 --- a/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.1.tm @@ -7,7 +7,7 @@ # (C) 2023 # # @@ Meta Begin -# Application punk::ns 0.1.0 +# Application punk::ns 0.1.1 # Meta platform tcl # Meta license # @@ Meta End @@ -4633,7 +4633,7 @@ y" {return quirkykeyscript} set vline [punk::args::ensemble_subcommands_definition -columns 2 $origin] set autoid "(autodef)$origin" - puts "ENSEMBLE auto def $autoid (generate_autodef)" + #puts "ENSEMBLE auto def $autoid (generate_autodef)" #A namespace can contain spaces, so an ensemble command can contain spaces. We must quote the -id value in the autodef set argdef [punk::lib::tstr -return string { @id -id "${$autoid}" @@ -4699,7 +4699,7 @@ y" {return quirkykeyscript} append argdef \n "@formdisplay -body {$tepamhelp}" punk::args::define $argdef } else { - puts "PROC auto def $autoid (generate_autodef)" + #puts "PROC auto def $autoid (generate_autodef)" #to handle procs like ":" (eg used by colin's bytecode based expr replacement) or other names of the form ":xyz" #we can't use 'info args :::' - tcl won't find it set ns [nsprefix $origin] @@ -5026,7 +5026,7 @@ y" {return quirkykeyscript} if {[punk::args::id_exists "$origin [lindex $args $i]"]} { set a [lindex $args $i] #review - tests? - puts stderr "cmd_traverse - skipping to documented subcommand '$origin $a'" + #puts stderr "cmd_traverse - skipping to documented subcommand '$origin $a'" #we can only seek beyond an undocumented subcommand level via a space delimited path, as we can make no assumption about the actual location of a subcommand relative to its parent #There could be a different command at for example "${origin}::$a" which is unrelated to the actual resolution path. set docid_exists 1 @@ -5120,7 +5120,7 @@ y" {return quirkykeyscript} lappend resolvedargs $q lpop queryargs_untested 0 lappend eparams $q - puts stderr "---> cmd_traverse ensembleparam $q ($lname)" + #puts stderr "---> cmd_traverse ensembleparam $q ($lname)" #puts stderr "arginfo: $arginfo" #puts stderr "---> eparams: $eparams" #puts stderr "---> existing args: $args" @@ -5304,7 +5304,7 @@ y" {return quirkykeyscript} } } #REVIEW!!! - puts stderr "cmd_traverse 10 $origin $resolvedargs $queryargs_untested $docid - review" + #puts stderr "cmd_traverse 10 $origin $resolvedargs $queryargs_untested $docid - review" return [list 10 $origin $resolvedargs $queryargs_untested $docid] } @@ -7591,6 +7591,6 @@ namespace eval ::punk::args::register { ## Ready package provide punk::ns [tcl::namespace::eval punk::ns { variable version - set version 0.1.0 + set version 0.1.1 }] return \ No newline at end of file diff --git a/src/bootsupport/modules/punk/packagepreference-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.1.tm similarity index 98% rename from src/bootsupport/modules/punk/packagepreference-0.1.0.tm rename to src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.1.tm index 38b1f3fd..8ad1d774 100644 --- a/src/bootsupport/modules/punk/packagepreference-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.1.tm @@ -8,7 +8,7 @@ # (C) 2024 # # @@ Meta Begin -# Application punk::packagepreference 0.1.0 +# Application punk::packagepreference 0.1.1 # Meta platform tcl # Meta license # @@ Meta End @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_punk::packagepreference 0 0.1.0] +#[manpage_begin punkshell_module_punk::packagepreference 0 0.1.1] #[copyright "2024"] #[titledesc {punkshell package/module loading}] [comment {-- Name section and table of contents description --}] #[moddesc {package/module load}] [comment {-- Description at end of page heading --}] @@ -321,7 +321,9 @@ tcl::namespace::eval punk::packagepreference { if {[catch {thread::id} threadid]} { set threadid "unknown-threadid" } - puts stdout "punk::packagepreference overloaded 'package require': Loaded punk::args::moduledoc::$dp for package '$pkg' threadid: $threadid" + #notice goes to stderr: stdout must stay clean for script/exec contexts + #(e.g the punk executable's 'script' subcommand - machine-consumed output) + puts stderr "punk::packagepreference overloaded 'package require': Loaded punk::args::moduledoc::$dp for package '$pkg' threadid: $threadid" } } #--------------------------------------------------------------- @@ -487,7 +489,7 @@ namespace eval ::punk::args::register { package provide punk::packagepreference [tcl::namespace::eval punk::packagepreference { variable pkg punk::packagepreference variable version - set version 0.1.0 + set version 0.1.1 }] return diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.2.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.2.2.tm similarity index 93% rename from src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.2.1.tm rename to src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.2.2.tm index 5ad6a0dc..0ae49215 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.2.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.2.2.tm @@ -7,7 +7,7 @@ # (C) 2023 # # @@ Meta Begin -# Application punk::path 0.2.1 +# Application punk::path 0.2.2 # Meta platform tcl # Meta license # @@ Meta End @@ -17,7 +17,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_punk::path 0 0.2.1] +#[manpage_begin punkshell_module_punk::path 0 0.2.2] #[copyright "2023"] #[titledesc {Filesystem path utilities}] [comment {-- Name section and table of contents description --}] #[moddesc {punk path filesystem utils}] [comment {-- Description at end of page heading --}] @@ -485,6 +485,87 @@ namespace eval punk::path { return relative } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::punk::path::scriptlib_resolve + @cmd -name "punk::path::scriptlib_resolve"\ + -summary\ + "Resolve a scriptlib script name to a path using the punk kit search policy"\ + -help\ + "Resolves a relative script name (the part after a 'lib:' prefix + in punk executable launch arguments) against the scriptlib + locations, in the same order the punk shell uses: + + 1. the kit vfs internal scriptlib (/app/scriptlib, + or /scriptlib for an unwrapped kit directory). + Internal scripts are deliberately NOT overridable by + external files (integrity and performance). + 2. /scriptlib - e.g /scriptlib for + an executable in /bin. + 3. /scriptlib. + + If the name's extension (lowercased) is not one of the known + scriptlib extensions (.tcl .py .pl .ps1 .sh), '.tcl' is + appended - only .tcl scripts may be named extensionlessly. + + Returns a dict with keys: + path - resolved absolute path, or empty string if not found + scriptname - the name searched for (extension applied) + candidates - the locations that were (or would be) checked, + for use in error messages. + Raises an error if name is not a relative path." + @leaders + name -type string -optional 0 -help\ + "relative script name, with or without a known extension + (any leading lib: prefix should already be stripped)" + }] + } + proc scriptlib_resolve {name} { + #shared resolution policy for the 'lib:' script prefix - used by the punk + #executable 'script' subcommand (app-punkscript); app-punkshell's shell + #subcommand encodes the same policy (todo: refactor it onto this proc). + if {[lindex [pathtype $name] 0] ne "relative"} { + error "punk::path::scriptlib_resolve name must be a relative path (got '$name')" + } + set known_extensions [list .tcl .py .pl .ps1 .sh] + if {[string tolower [file extension $name]] ni $known_extensions} { + #only .tcl scripts allowed to be called extensionlessly + set scriptname $name.tcl + } else { + set scriptname $name + } + set exepath [file dirname [file normalize [file join [info nameofexecutable] ___]]] ;#symlink resolve + set candidates [list] + #1) kit-internal scriptlib - not overridable externally + set has_zipfs_command [expr {[info commands ::tcl::zipfs::root] ne ""}] + set kit_base "" + if {$has_zipfs_command && [file exists [tcl::zipfs::root]]} { + set kit_base [tcl::zipfs::root] + } elseif {[file type $exepath] eq "directory"} { + set kit_base $exepath + } + set kit_libdir "" + if {$has_zipfs_command && $kit_base ne "" && [file exists $kit_base/app/scriptlib]} { + set kit_libdir $kit_base/app/scriptlib + } elseif {[file exists $exepath/scriptlib]} { + set kit_libdir $exepath/scriptlib + } + if {$kit_libdir ne ""} { + lappend candidates $kit_libdir/$scriptname + if {[file exists $kit_libdir/$scriptname]} { + return [dict create path $kit_libdir/$scriptname scriptname $scriptname candidates $candidates] + } + } + #2,3) external scriptlib folders relative to the executable location + set exedir [file dirname $exepath] + foreach dir [list [file join $exedir scriptlib] [file join [file dirname $exedir] scriptlib]] { + lappend candidates [file join $dir $scriptname] + if {[file isdirectory $dir] && [file exists [file join $dir $scriptname]]} { + return [dict create path [file join $dir $scriptname] scriptname $scriptname candidates $candidates] + } + } + return [dict create path "" scriptname $scriptname candidates $candidates] + } proc plain {str} { set str [string map "\\\\ /" $str] @@ -1598,12 +1679,19 @@ namespace eval punk::path::system { } + +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + #documentation-only PUNKARGS registration - discovered lazily if/when punk::args loads + lappend ::punk::args::register::NAMESPACES ::punk::path::argdoc +} + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready package provide punk::path [namespace eval punk::path { variable pkg punk::path variable version - set version 0.2.1 + set version 0.2.2 }] return diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.2.3.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.2.4.tm similarity index 99% rename from src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.2.3.tm rename to src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.2.4.tm index 4f64e822..d060aced 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.2.3.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.2.4.tm @@ -2813,8 +2813,11 @@ namespace eval shellfilter { set syslog [dict get $opts -syslog] dict unset opts -syslog set runtag "shellfilter-run" - set tid [::shellfilter::log::open $runtag [list -syslog 127.0.0.1:514]] - #set tid [::shellfilter::log::open $runtag [list -syslog $syslog]] + #honor the -syslog option (default empty) - the previous hardcoded 127.0.0.1:514 was a + #debug leftover. With no -syslog and no -file the runtag log worker is a noop (no thread + #is created). Syslog remains supported when explicitly configured; see G-036 for the + #Tcl 9 console+udp worker wedge that the always-on syslog worker exposed on exit/quit. + set tid [::shellfilter::log::open $runtag [list -syslog $syslog]] log::info {::shellfilter::log::write $runtag " opts: $opts"} log::info {::shellfilter::log::write $runtag " commandlist:'$commandlist' listlen:$listlen strlen:[string length $commandlist]"} @@ -3827,5 +3830,5 @@ namespace eval shellfilter { package provide shellfilter [namespace eval shellfilter { variable version - set version 0.2.3 + set version 0.2.4 }] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellthread-1.6.2.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellthread-1.6.3.tm similarity index 97% rename from src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellthread-1.6.2.tm rename to src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellthread-1.6.3.tm index 79d12149..cd0c83c6 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellthread-1.6.2.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellthread-1.6.3.tm @@ -788,8 +788,12 @@ namespace eval shellthread::manager { foreach workertid $subscriberless_workers { if {$workertid ni $shuttingdown_workers} { if {$workertid ni $free_threads && $workertid ne "noop"} { - #JMN - thread::send $workertid {set ::shellthread::worker::settings $::shellthread::worker::settings_defaults} + #Must be async: unsubscribe is on the exit/quit teardown path and a worker whose + #event loop has stopped servicing events (G-036: Tcl 9 console+udp worker wedge) + #would block a synchronous send forever, freezing the shell. Async is safe - + #sends to a thread are processed FIFO, so a later reuse via new_worker sees the + #settings reset applied before anything it sends. + thread::send -async $workertid {set ::shellthread::worker::settings $::shellthread::worker::settings_defaults} #todo - log freeing up of thread lappend free_threads $workertid } @@ -812,7 +816,10 @@ namespace eval shellthread::manager { } proc get_tag_config {tag} { - #review + #review - bare synchronous thread::send: blocks forever if the worker's event loop is + #wedged (G-036 hazard class). Reached from new_worker when a tag already has a live + #worker. Needs a result so can't simply go async - convert to async + vwait-with-timeout + #if this path shows up in a hang. variable workers if {![dict exists $workers $tag]} { error "shellthread::manager::get_tag_config error no existing tag $tag" @@ -858,10 +865,13 @@ namespace eval shellthread::manager { set timedout 1 break } else { - after cancel $timeout_timer + #Do not cancel the timeout timer until all awaited workers have responded - + #cancelling on the first response left later vwait iterations unbounded, so a + #wedged worker (G-036) after a healthy one hung shutdown forever. lappend ended $::shellthread::waitfor } } + after cancel $timeout_timer } set free_threads [list] return [dict create existed $waiting_for ended $ended timedout $timedout allthreads [thread::names]] @@ -963,7 +973,7 @@ namespace eval shellthread::manager { package provide shellthread [namespace eval shellthread { variable version - set version 1.6.2 + set version 1.6.3 }] diff --git a/src/bootsupport/modules/tomlish-1.1.8.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/tomlish-1.1.10.tm similarity index 98% rename from src/bootsupport/modules/tomlish-1.1.8.tm rename to src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/tomlish-1.1.10.tm index e1be4767..68ac58f8 100644 --- a/src/bootsupport/modules/tomlish-1.1.8.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/tomlish-1.1.10.tm @@ -7,7 +7,7 @@ # (C) 2024 # # @@ Meta Begin -# Application tomlish 1.1.8 +# Application tomlish 1.1.10 # Meta platform tcl # Meta license # @@ Meta End @@ -17,7 +17,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin tomlish_module_tomlish 0 1.1.8] +#[manpage_begin tomlish_module_tomlish 0 1.1.10] #[copyright "2024"] #[titledesc {tomlish toml parser}] [comment {-- Name section and table of contents description --}] #[moddesc {tomlish}] [comment {-- Description at end of page heading --}] @@ -385,6 +385,45 @@ namespace eval tomlish { } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::tomlish::to_dict + @cmd -name "tomlish::to_dict"\ + -summary\ + "Convert a tomlish structure to a Tcl dict with typed leaf values"\ + -help\ + "Converts tomlish (the tagged-list representation produced + by tomlish::from_toml) to a Tcl dict datastructure. + + Toml tables map to nested dict keys. Each leaf value is a + two-element dict of the form {type value } + where is a toml/tomlish type such as INT, FLOAT, + BOOL, STRING, LITERAL, MULTISTRING, MULTILITERAL, DATETIME + or ARRAY (an ARRAY value is a list of typed elements). + Escape sequences in quoted strings are substituted during + this conversion. + + Whitespace and comments are not represented in the result, + so a dict alone cannot round-trip formatting - use + tomlish::update_tomlish_from_dict to write dict values back + into an existing tomlish structure when preservation + matters. + + Toml validity rules that require whole-document knowledge + (e.g 'You cannot define any key or table more than once') + are enforced here and raise errors. + + Returns the dict, or with returnextra true a dict with keys + 'datastructure' (the converted dict) and 'tablenames_info' + (per-tablename creation/definition metadata)." + @leaders + tomlish -type list -optional 0 -help\ + "tomlish tagged list (e.g from tomlish::from_toml)" + returnextra -type boolean -optional 1 -default 0 -help\ + "when true, return a dict of keys 'datastructure' and + 'tablenames_info' instead of the datastructure alone" + }] + } proc to_dict {tomlish {returnextra 0}} { tomlish::dict::from_tomlish $tomlish $returnextra } @@ -708,6 +747,31 @@ namespace eval tomlish { } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::tomlish::from_dict + @cmd -name "tomlish::from_dict"\ + -summary\ + "Convert a dict with typed leaf values to a tomlish structure"\ + -help\ + "Converts a Tcl dict whose leaf values are typed + ({type value } - the form produced by + tomlish::to_dict) into a new tomlish tagged-list structure, + which tomlish::to_toml can serialise to toml text. + + The dict must be a full typed representation - plain + untyped leaf values are not accepted. As a dict carries no + whitespace/comment information, the generated tomlish (and + any toml produced from it) uses generated formatting; to + preserve the formatting of an existing document, write + values back with tomlish::update_tomlish_from_dict instead. + + Returns the tomlish list." + @leaders + d -type dict -optional 0 -help\ + "dict with typed leaf values (e.g from tomlish::to_dict)" + }] + } proc from_dict {d} { #consider: # t1={a=1,b=2} @@ -906,6 +970,33 @@ namespace eval tomlish { # For this reason, we also do absolutely no line-ending transformations based on platform. # All line-endings are maintained as is, and even a file with mixed lf crlf line-endings will be correctly interpreted and can be 'roundtripped' + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::tomlish::from_toml + @cmd -name "tomlish::from_toml"\ + -summary\ + "Parse toml text into a tomlish tagged-list structure"\ + -help\ + "Parses toml source text into 'tomlish' - the intermediate + tagged-list representation used by the tomlish package. + + tomlish is whitespace and comment preserving: serialising + the result with tomlish::to_toml reproduces the input byte + for byte (lossless round-trip). No escape sequences in + quoted strings are processed at this stage and no + line-ending transformations are performed - that occurs in + datastructure conversions such as tomlish::to_dict. + + Returns the tomlish list: first element is the tag TOMLISH, + remaining elements are tagged records such as TABLE, + TABLEARRAY, DOTTEDKEY, WS, COMMENT, NEWLINE. + Raises an error for invalid toml." + @values -min 1 -max -1 + toml -type string -optional 0 -multiple 1 -help\ + "toml source text. Multiple values are joined with newline + characters before parsing." + }] + } proc from_toml {args} { namespace upvar ::tomlish::parse s s @@ -1764,6 +1855,34 @@ namespace eval tomlish { # updating from a subset dict (reduces processing - and more flexible to supply only paths to leaves requiring update?) # #todo - allow adding extra leaves e.g keys in tables,tablearrays, itables, arrays + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::tomlish::update_tomlish_from_dict + @cmd -name "tomlish::update_tomlish_from_dict"\ + -summary\ + "Update leaf values in a tomlish structure from a typed dict, preserving formatting"\ + -help\ + "Merges values from dict d into an existing tomlish + structure and returns the updated tomlish, in which + whitespace, comments and key ordering are preserved. + + This is the formatting-preserving write path: parse a + document with tomlish::from_toml, convert with + tomlish::to_dict, modify values in the dict, apply them + with this command, then serialise with tomlish::to_toml. + + d must be a full typed representation of the datastructure + (as produced by tomlish::to_dict). The initial + implementation updates leaf values only - adding or pruning + keys/branches is not yet supported." + @leaders + tomlish -type list -optional 0 -help\ + "existing tomlish tagged list (e.g from tomlish::from_toml)" + d -type dict -optional 0 -help\ + "full typed-dict representation carrying the updated leaf + values" + }] + } proc update_tomlish_from_dict {tomlish d} { set returnextra true #validate supplied tomlish and keep tablenames_info (review - validate structure only - allow invalid values to be overwritten from dict?) @@ -2441,6 +2560,34 @@ namespace eval tomlish::encode { #fish toml from tomlish #(encode tomlish as toml) +namespace eval ::tomlish::argdoc { + lappend PUNKARGS [list { + @id -id ::tomlish::to_toml + @cmd -name "tomlish::to_toml"\ + -summary\ + "Serialise a tomlish structure to toml text"\ + -help\ + "Encodes tomlish (the tagged-list representation produced by + tomlish::from_toml or tomlish::from_dict) as toml text. + + For tomlish obtained from tomlish::from_toml this reproduces + the original document byte for byte, including whitespace and + comments (lossless round-trip). + + Validation here is structural only - toml validity rules that + need whole-document knowledge (e.g duplicate keys/tables) are + not detected; they are the role of the dict conversion pair + tomlish::to_dict / tomlish::from_dict. + + tomlish::to_toml is an alias of tomlish::encode::tomlish. + Returns the toml text." + @leaders + list -type list -optional 0 -help\ + "tomlish tagged list" + context -type string -optional 1 -default "" -help\ + "internal recursion context tag - omit in normal use" + }] +} interp alias {} tomlish::to_toml {} tomlish::encode::tomlish # @@ -9408,12 +9555,48 @@ namespace eval tomlish::system { #[list_end] [comment {--- end definitions namespace tomlish::system ---}] } +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + #documentation-only PUNKARGS registration - discovered lazily if/when punk::args is loaded; + #adds no punk::args dependency to the tomlish library itself. + lappend ::punk::args::register::NAMESPACES ::tomlish::argdoc +} + # if {[info exists ::argc] && $::argc > 0} {} ;#not a valid way to test if main script -if {[tomlish::system::is_main_script]} { - #puts stderr "argc: $::argc args: $::argv" - set arglist $::argv +namespace eval tomlish { + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::tomlish::cmdline_main + @cmd -name "tomlish::cmdline_main"\ + -summary\ + "Run the tomlish command-line application on an argument list"\ + -help\ + "Explicit entry point for the tomlish command-line app + (usage display and -app dispatch to the tomlish::app::* + applications such as decode_to_typedjson, + encode_from_typedjson, test). + + Called automatically with \$::argv when the tomlish module + file is the main script (tclsh tomlish.tcl ...). Launchers + such as a wrapped tomlish executable's app package must + call this explicitly after package require tomlish - since + the tomlish::system::is_main_script gate (1.1.8) the app + no longer runs as a load-time side effect of ::argc/::argv + being set. + + Zeroes the global ::argv/::argc before loading dependent + packages (argument hygiene) and terminates the process via + exit on every path: 0 for success/help, 1 for usage or + application errors." + @leaders + arglist -type list -optional 0 -help\ + "command-line argument list (typically \$::argv)" + }] + } +} +proc ::tomlish::cmdline_main {arglist} { # -------------- #make sure any dependant packages that are sourced don't get any commandline args set ::argv {} @@ -9476,11 +9659,16 @@ if {[tomlish::system::is_main_script]} { } } +if {[tomlish::system::is_main_script]} { + #puts stderr "argc: $::argc args: $::argv" + tomlish::cmdline_main $::argv +} + ## Ready package provide tomlish [namespace eval tomlish { variable pkg tomlish variable version - set version 1.1.8 + set version 1.1.10 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk-0.2.0.tm similarity index 94% rename from src/vfs/_vfscommon.vfs/modules/punk-0.1.1.tm rename to src/vfs/_vfscommon.vfs/modules/punk-0.2.0.tm index 8fa2cac2..a8086722 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk-0.2.0.tm @@ -8411,38 +8411,507 @@ namespace eval punk { } puts -nonewline stdout \n } - #return list of {chan chunk} elements - namespace eval argdoc { + #punk::help topic registry + #Each registered topic has: + # - a handler proc ::punk::helptopic:: taking a context dict plus any extra words, + # returning the topic's help content as a list of {channel text} chunks + # - a punk::args definition with id ::punk::helptopic:: so that 'i help ' shows documented usage + #Registering a topic (re)generates the ::punk::help and ::punk::help_chunks punk::args definitions, + #so the documented topic choices always match the registry. + #The 'overview' handler is not a registered topic - it is what a plain 'help' displays. + #Unregistered topic words fall through to basic command-info lookup (see ::punk::help_chunks). + namespace eval helptopic { + variable topics [dict create] + + tcl::namespace::import ::punk::ansi::a ::punk::ansi::a+ + + proc register {topic aliases summary} { + variable topics + if {![llength [info commands [namespace current]::$topic]]} { + error "punk::helptopic::register - no handler proc '[namespace current]::$topic' exists for topic '$topic'" + } + dict set topics $topic [dict create aliases $aliases summary $summary] + define_docs + return + } + + #return the canonical topic name for a topic word or alias - empty string if not a registered topic + proc resolve {word} { + variable topics + dict for {topic tinfo} $topics { + if {$word eq $topic || $word in [dict get $tinfo aliases]} { + return $topic + } + } + return "" + } + + #standard command-info table as used by the help overview blocks + proc table_block {frametype title rows {minwidth 80}} { + set t [textblock::class::table new -minwidth $minwidth -show_seps 0] + $t configure -frametype $frametype + foreach row $rows { + $t add_row $row + } + $t configure_column 0 -minwidth [expr {[$t column_datawidth 0] + 2}] + $t configure_column 1 -minwidth [expr {[$t column_datawidth 1] + 1}] + $t configure -title $title + set text [$t print] + $t destroy + return $text + } + + #(re)generate the punk::args definitions for ::punk::help and ::punk::help_chunks from the registry + #so that 'i help' shows a documented topic table matching the registered topics. + proc define_docs {} { + variable topics + set choices [list] + set choiceinfo [dict create] + set choicelabels [dict create] + dict for {topic tinfo} $topics { + foreach name [list $topic {*}[dict get $tinfo aliases]] { + lappend choices $name + dict set choiceinfo $name [list [list doctype punkargs] [list subhelp [namespace current]::$topic]] + dict set choicelabels $name [dict get $tinfo summary] + } + } + set basehelp {Help system for the punk shell. + With no arguments - an overview of some key shell commands is displayed. + When the first argument is a recognised topic - help for that topic is displayed. + ('help topics' lists the available topics) + Anything else is treated as a command name - basic command info (type and + synopsis) is shown for a resolvable command, or the resolved path for an + external executable.} + set topichelp {Help topic, or command words for basic command info. (topics must match exactly - no prefix matching)} + set specs [list] + lappend specs ::punk::help help "Punk shell help system." "" + lappend specs ::punk::help_chunks punk::help_chunks "Punk shell help system - content as {channel text} chunks." "\n\nhelp_chunks returns the help content as a list of {channel text} chunks rather than emitting it." + foreach {id name summary extra} $specs { + set def "" + append def "@id -id $id" \n + append def "@cmd -name $name -summary \"$summary\" -help \"$basehelp$extra\"" \n + append def "@leaders -min 0 -max -1" \n + append def "topic -optional 1 -multiple 1 -type string -choiceprefix 0 -choicerestricted 0 -choices {$choices} -choiceinfo {$choiceinfo} -choicelabels {$choicelabels} -help \"$topichelp\"" \n + append def "@values -min 0 -max 0" + if {[punk::args::id_exists $id]} { + #quiet undefine - redefinition on registry change is expected, not noteworthy + punk::args::undefine $id 1 + } + punk::args::define $def + } + } + + #The no-topic overview of key shell commands (what a plain 'help' displays) + proc overview {context args} { + set frametype [dict get $context frametype] + set I [dict get $context I] + set NI [dict get $context NI] + set chunks [list] + + set title "[a+ brightgreen] Filesystem navigation: " + set cmdinfo [list] + lappend cmdinfo [list ./ "?${I}glob${NI}?" "view/change dir, list dirs."] + lappend cmdinfo [list .// "?${I}glob${NI}?" "view/change dir, list dirs and files"] + lappend cmdinfo [list ../ "?${I}path${NI}" "go up one dir, then to path if given"] + 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)"] + lappend chunks [list stdout [table_block $frametype $title $cmdinfo]\n] + + 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 "newns" "${I}ns${NI}" "make child namespace and switch to it"] + lappend chunks [list stdout [table_block $frametype $title $cmdinfo]\n] + + set title "[a+ brightgreen] Command help: " + set cmdinfo [list] + lappend cmdinfo [list i "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show usage for a command or ensemble subcommand"] + lappend cmdinfo [list s "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show synopsis for a command or ensemble subcommand"] + lappend cmdinfo [list eg "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show example from manpage"] + lappend cmdinfo [list corp "${I}proc${NI}" "View proc body and arguments with basic highlighting"] + lappend chunks [list stdout [table_block $frametype $title $cmdinfo]\n] + + set title "[a+ brightgreen] Miscellaneous: " + #todo - load from source code annotation? + set cmdinfo [list] + lappend cmdinfo [list dev "?${I}subcommand${NI}?" "(ensemble command to make new projects/modules and\n to generate docs)"] + lappend cmdinfo [list a? "?${I}subcommand${NI}...?" "view ANSI colours\n e.g a? web\n or individual code samples/diagnostics\n e.g a? red bold\n e.g a? underline web-orange Term-purple3"] + lappend cmdinfo [list a+ "?${I}colourcode${NI}...?" "Return ANSI codes\n e.g puts \"\[a+ purple\]purple\[a+ Green\]purple on green\[a\]\"\n [a+ purple]purple[a+ Green]purple on green[a] "] + lappend cmdinfo [list a "?${I}colourcode${NI}...?" "Return ANSI codes (with leading reset)\n e.g puts \"\[a+ purple\]purple\[a Green\]normal on green\[a\]\"\n [a+ purple]purple[a Green]normal on green[a] "] + lappend chunks [list stdout [table_block $frametype $title $cmdinfo]] + + return $chunks + } + punk::args::define { - @id -id ::punk::help_chunks - @cmd -name "punk::help_chunks"\ - -summary\ - ""\ - -help\ - "" - @opts - -- -type none - @values -min 0 -max -1 - arg -type any -optional 1 -multiple 1 + @id -id ::punk::helptopic::topics + @cmd -name "help topics" -summary "List help topics." -help "Show the table of topics known to the help system, including registered aliases for each topic." + @values -min 0 -max 0 + } + proc topics {context args} { + variable topics + set frametype [dict get $context frametype] + set t [textblock::class::table new -show_seps 0] + $t configure -frametype $frametype + $t add_column -headers [list "Topic"] + $t add_column + dict for {topic tinfo} $topics { + $t add_row [list [join [list $topic {*}[dict get $tinfo aliases]] |] [dict get $tinfo summary]] + } + $t add_row [list "*" "Look up as a command or external executable"] + $t configure_column 0 -minwidth [expr {[$t column_datawidth 0] + 4}] + set text \n[$t print] + $t destroy + return [list [list stdout $text]] + } + + punk::args::define { + @id -id ::punk::helptopic::tcl + @cmd -name "help tcl" -summary "Tcl version warnings." -help "Show the running Tcl patchlevel and build-info, with warnings for known Tcl bugs affecting this interpreter (as detected by the punk::lib::check::has_tclbug_* checks)." + @values -min 0 -max 0 + } + proc tcl {context args} { + set chunks [list] + set warningblock "" + set text "Tcl Patchlevel: [info patchlevel]" + catch { + append text \n "Tcl build-info: [::tcl::build-info]" + } + #generate warningblocks for each triggered Tcl bug in namespace ::punk::lib::check + set bugcheck_procs [info procs ::punk::lib::check::has_tclbug*] + foreach bp $bugcheck_procs { + set buginfo [$bp] + if {[dict get $buginfo bug]} { + set level unknown + if {[dict exists $buginfo level]} { + set level [dict get $buginfo level] + } + switch -- $level { + minor {set highlight [punk::ansi::a+ cyan]} + medium {set highlight [punk::ansi::a+ yellow]} + major {set highlight [punk::ansi::a+ red bold]} + default {set highlight ""} + } + append warningblock \n $highlight "warning level: $level $bp triggered." + if {[dict exists $buginfo description]} { + set indent " " + append warningblock \n "[punk::lib::indent [dict get $buginfo description] $indent]" + } + if {[dict exists $buginfo bugref] && [dict get $buginfo bugref] ne ""} { + set bugref [dict get $buginfo bugref] + append warningblock \n "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/$bugref]" + } + append warningblock [a] + } + } + + if {[catch {lsearch -stride 2 {a b} b}]} { + #has_tclbug_lsearch_strideallinline will have reported bug false because it couldn't test it. + set indent " " + append warningblock \n "[a+ web-red]warning: lsearch does not seem to support -stride option" \n + append warningblock "${indent}(Consider upgrading to a late release of tcl 8.6 or tcl 9+ )" \n + append warningblock [a] + } + lappend chunks [list stdout $text] + lappend chunks [list stderr $warningblock] + return $chunks + } + + punk::args::define { + @id -id ::punk::helptopic::env + @cmd -name "help env" -summary "punkshell environment vars." -help "Show punk-related and other relevant environment variables with their current values." + @values -min 0 -max 0 + } + proc env {context args} { + if {[catch {package require punk::config} errM]} { + return [list [list stderr "help env: punk::config package not available - no environment variable info ($errM)\n"]] + } + if {![info exists ::punk::config::punk_env_vars_config] || ![info exists ::punk::config::other_env_vars_config]} { + #punk::config::init has side effects (config dir/file creation) - don't trigger it just for help + return [list [list stderr "help env: punk::config not initialised - no environment variable info\n"]] + } + set frametype [dict get $context frametype] + set linesep [string repeat - 76] + set chunks [list] + set text "" + #todo - move to punk::config? + upvar ::punk::config::punk_env_vars_config punkenv_config + upvar ::punk::config::other_env_vars_config otherenv_config + + set known_punk [dict keys $punkenv_config] + set known_other [dict keys $otherenv_config] + append text \n + set usetable 1 + if {$usetable} { + set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] + $t configure -frametype $frametype + if {"windows" eq $::tcl_platform(platform)} { + #If any env vars have been set to empty string - this is considered a deletion of the variable on windows. + #The Tcl ::env array is linked to the underlying process view of the environment + #- but info exists ::env(var) can misreport as true if it has been deleted by setting to empty string rather than using unset. + #an 'array get' will resynchronise. + #Even if an env variable didn't exist before - setting it to empty string can get it to this inconsistent state. + array get ::env + } + #do an array read on ::env + foreach {v vinfo} $punkenv_config { + if {[info exists ::env($v)]} { + set c2 [set ::env($v)] + } else { + set c2 "(NOT SET)" + } + set help "" + if {[dict exists $vinfo help]} { + set help [dict get $vinfo help] + } + $t add_row [list $v $c2 $help] + } + $t configure_column 0 -headers [list "Punk environment vars"] + $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} + + set punktable [$t print] + $t destroy + + set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] + $t configure -frametype $frametype + foreach {v vinfo} $otherenv_config { + if {[info exists ::env($v)]} { + set env_val [set ::env($v)] + if {[string match "*_TM_PATH" $v]} { + set entries [split $env_val $::tcl_platform(pathSeparator)] + set c2 [join $entries \n] + } else { + set c2 $::env($v) + } + } else { + set c2 "(NOT SET)" + } + $t add_row [list $v $c2] + } + $t configure_column 0 -headers [list "Other environment vars"] + $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} + + set othertable [$t print] + $t destroy + #append text [textblock::join -- $punktable " " $othertable]\n + append text $punktable\n$othertable\n + } else { + + append text $linesep\n + append text "punk environment vars:\n" + append text $linesep\n + set col1 [string repeat " " 25] + set col2 [string repeat " " 50] + foreach v $known_punk { + set c1 [overtype::left $col1 $v] + if {[info exists ::env($v)]} { + set c2 [overtype::left $col2 [set ::env($v)]] + } else { + set c2 [overtype::right $col2 "(NOT SET)"] + } + append text "$c1 $c2\n" + } + append text $linesep\n + } + + lappend chunks [list stdout $text] + return $chunks + } + + punk::args::define { + @id -id ::punk::helptopic::console + @cmd -name "help console" -summary "Console behaviour tests and warnings." -help "Run some console/terminal behaviour tests (control string hiding, grapheme cluster support, cursor position query timing) and report warnings. Requires a responsive interactive console." + @values -min 0 -max 0 + } + proc console {context args} { + set chunks [list] + set warningblock "" + set term_env_vars {TERM TERM_PROGRAM TERM_PROGRAM_VERSION COLORTERM} + set term_dict [dict create] + foreach e $term_env_vars { + if {[info exists ::env($e)]} { + dict set term_dict $e [set ::env($e)] + } else { + dict set term_dict $e "(NOT SET)" + } + } + set text "Terminal environment variables:\n" + append text [punk::lib::showdict $term_dict] \n + lappend chunks [list stdout $text] + set text "" + set indent [string repeat " " [string length "WARNING: "]] + + 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 { + + if {![catch {punk::console::class_info} console_class_info]} { + set text "Terminal class info (from device secondary attributes query to terminal):\n" + append text [punk::lib::showdict $console_class_info] \n + } else { + set text "Unable to query terminal class info - err:$console_class_info\n" + } + lappend chunks [list stdout $text] + + 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" + } + } + 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" + } + + 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" + } + + + 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 posn [punk::console::get_cursor_pos] ;#warmup call - and test if works + if {$posn eq ""} { + append warningblock \n "WARNING: terminal doesn't respond to cursor position query - may cause display bugs in some cases." + } else { + set timeresult [timerate {set cpos [punk::console::get_cursor_pos]}] + lassign [split $cpos {;}] row col + if {![string is integer -strict $row] || ![string is integer -strict $col]} { + append warningblock \n "WARNING: terminal returns non-integer values for cursor position query - may cause display bugs in some cases. got row:'$row' col:'$col'" + } else { + set micros [lindex $timeresult 0] + if {$micros > 2000} { + append warningblock \n "WARNING: terminal cursor position query is very slow ($micros microseconds - expect < 2000us )" + append warningblock \n $indent "- may cause display lag/bugs in some cases." + } else { + if {$micros > 1000} { + set text "\n[a+ yellow]Terminal cursor position query test passed." + append text \n $indent "Response time: ${micros} microseconds (OK, good would be <= 1000us).[a]" + + } else { + set text "[a+ green]Terminal cursor position query test passed." + append text \n $indent "Response time: ${micros} microseconds (GOOD).[a]" + } + lappend chunks [list stdout $text] + } + } + } + + + if {![string length $warningblock]} { + set text "[a+ green]No terminal warnings[a]\n" + lappend chunks [list stdout $text] + } else { + set mode [punk::console::mode] + if {$mode eq "line"} { + append warningblock \n "Terminal appears to be in line mode. Consider switching to raw mode and re-testing (command: punk::console::mode raw)." + } + } + puts stdout [punk::ansi::move_back 200] ;#hack for some horizontal position bugs where the above tests can leave the cursor in the wrong place for the next output. + #200 is arbitrary large number to move back enough to get to start of line. + } + lappend chunks [list stderr $warningblock] + return $chunks } + + register topics {help} "List help topics" + register tcl {} "Tcl version warnings" + register env {environment} "punkshell environment vars" + register console {term terminal} "Some console behaviour tests and warnings" } + + #return list of {chan chunk} elements proc help_chunks {args} { - set argd [punk::args::parse $args withid ::punk::help_chunks] + set argd [punk::args::parse $args withid ::punk::help] lassign [dict values $argd] leaders opts values received - if {[dict exists $values arg]} { - set topicparts [dict get $values arg] + if {[dict exists $leaders topic]} { + set topicparts [dict get $leaders topic] } else { set topicparts [list ""] } - #set topic [lindex $args end] - #set argopts [lrange $args 0 end-1] - set chunks [list] - set linesep [string repeat - 76] - - set warningblock "" set I [punk::ansi::a+ italic] set NI [punk::ansi::a+ noitalic] @@ -8471,6 +8940,8 @@ namespace eval punk { } + set context [dict create cols $cols rows $rows frametype $frametype I $I NI $NI] + # ------------------------------------------------------- set logoblock "" if {[catch { @@ -8483,473 +8954,54 @@ namespace eval punk { set title "[a+ brightgreen] Help System: " set cmdinfo [list] lappend cmdinfo [list help "?${I}topic${NI}?" "This help.\nTo see available subitems type:\nhelp topics\n\nFor an unrecognised ${I}topic${NI}\nhelp will look for basic\ninfo for it as a command.\n"] - set t [textblock::class::table new -minwidth 51 -show_seps 0] - $t configure -frametype $frametype - foreach row $cmdinfo { - $t add_row $row - } - set width_0 [$t column_datawidth 0] - $t configure_column 0 -minwidth [expr {$width_0 + 2}] - set width_1 [$t column_datawidth 1] - $t configure_column 1 -minwidth [expr {$width_1 + 1}] - $t configure -title $title - set text [$t print] + set text [helptopic::table_block $frametype $title $cmdinfo 51] set introblock [textblock::join -- $logoblock $text] lappend chunks [list stdout $introblock\n] # ------------------------------------------------------- - switch -- [lindex $topicparts 0] { - "" { - - # ------------------------------------------------------- - set title "[a+ brightgreen] Filesystem navigation: " - set cmdinfo [list] - lappend cmdinfo [list ./ "?${I}glob${NI}?" "view/change dir, list dirs."] - lappend cmdinfo [list .// "?${I}glob${NI}?" "view/change dir, list dirs and files"] - lappend cmdinfo [list ../ "?${I}path${NI}" "go up one dir, then to path if given"] - 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] - $t configure -frametype $frametype - foreach row $cmdinfo { - $t add_row $row - } - set width_0 [$t column_datawidth 0] - $t configure_column 0 -minwidth [expr {$width_0 + 2}] - set width_1 [$t column_datawidth 1] - $t configure_column 1 -minwidth [expr {$width_1 + 1}] - $t configure -title $title - - set text "" - append text [$t print] - lappend chunks [list stdout $text\n] - # ------------------------------------------------------- - - - # ------------------------------------------------------- - 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 "newns" "${I}ns${NI}" "make child namespace and switch to it"] - set t [textblock::class::table new -minwidth 80 -show_seps 0] - $t configure -frametype $frametype - foreach row $cmdinfo { - $t add_row $row - } - set width_0 [$t column_datawidth 0] - $t configure_column 0 -minwidth [expr {$width_0 + 2}] - set width_1 [$t column_datawidth 1] - $t configure_column 1 -minwidth [expr {$width_1 + 1}] - $t configure -title $title - - set text "" - append text [$t print] - lappend chunks [list stdout $text\n] - # ------------------------------------------------------- - - # ------------------------------------------------------- - set title "[a+ brightgreen] Command help: " - set cmdinfo [list] - lappend cmdinfo [list i "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show usage for a command or ensemble subcommand"] - lappend cmdinfo [list s "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show synopsis for a command or ensemble subcommand"] - lappend cmdinfo [list eg "${I}cmd${NI} ?${I}subcommand${NI}...?" "Show example from manpage"] - lappend cmdinfo [list corp "${I}proc${NI}" "View proc body and arguments with basic highlighting"] - set t [textblock::class::table new -minwidth 80 -show_seps 0] - $t configure -frametype $frametype - foreach row $cmdinfo { - $t add_row $row - } - set width_0 [$t column_datawidth 0] - $t configure_column 0 -minwidth [expr {$width_0 + 2}] - set width_1 [$t column_datawidth 1] - $t configure_column 1 -minwidth [expr {$width_1 + 1}] - $t configure -title $title - - set text "" - append text [$t print] - lappend chunks [list stdout $text\n] - # ------------------------------------------------------- - - - set title "[a+ brightgreen] Miscellaneous: " - #todo - load from source code annotation? - set cmdinfo [list] - lappend cmdinfo [list dev "?${I}subcommand${NI}?" "(ensemble command to make new projects/modules and\n to generate docs)"] - lappend cmdinfo [list a? "?${I}subcommand${NI}...?" "view ANSI colours\n e.g a? web\n or individual code samples/diagnostics\n e.g a? red bold\n e.g a? underline web-orange Term-purple3"] - lappend cmdinfo [list a+ "?${I}colourcode${NI}...?" "Return ANSI codes\n e.g puts \"\[a+ purple\]purple\[a+ Green\]purple on green\[a\]\"\n [a+ purple]purple[a+ Green]purple on green[a] "] - lappend cmdinfo [list a "?${I}colourcode${NI}...?" "Return ANSI codes (with leading reset)\n e.g puts \"\[a+ purple\]purple\[a Green\]normal on green\[a\]\"\n [a+ purple]purple[a Green]normal on green[a] "] - - set t [textblock::class::table new -minwidth 80 -show_seps 0] - $t configure -frametype $frametype - foreach row $cmdinfo { - $t add_row $row - } - set width_0 [$t column_datawidth 0] - $t configure_column 0 -minwidth [expr {$width_0 + 2}] - set width_1 [$t column_datawidth 1] - $t configure_column 1 -minwidth [expr {$width_1 + 1}] - $t configure -title $title - - set text "" - append text [$t print] - lappend chunks [list stdout $text] - # ------------------------------------------------------- - - } - tcl { - set text "Tcl Patchlevel: [info patchlevel]" - catch { - append text \n "Tcl build-info: [::tcl::build-info]" - } - #generate warningblocks for each triggered Tcl bug in namespace ::punk::lib::check - set bugcheck_procs [info procs ::punk::lib::check::has_tclbug*] - foreach bp $bugcheck_procs { - set buginfo [$bp] - if {[dict get $buginfo bug]} { - set level unknown - if {[dict exists $buginfo level]} { - set level [dict get $buginfo level] - } - switch -- $level { - minor {set highlight [punk::ansi::a+ cyan]} - medium {set highlight [punk::ansi::a+ yellow]} - major {set highlight [punk::ansi::a+ red bold]} - default {set highlight ""} - } - append warningblock \n $highlight "warning level: $level $bp triggered." - if {[dict exists $buginfo description]} { - set indent " " - append warningblock \n "[punk::lib::indent [dict get $buginfo description] $indent]" - } - if {[dict exists $buginfo bugref] && [dict get $buginfo bugref] ne ""} { - set bugref [dict get $buginfo bugref] - append warningblock \n "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/$bugref]" - } - append warningblock [a] - } - } - - if {[catch {lsearch -stride 2 {a b} b}]} { - #has_tclbug_lsearch_strideallinline will have reported bug false because it couldn't test it. - set indent " " - append warningblock \n "[a+ web-red]warning: lsearch does not seem to support -stride option" \n - append warningblock "${indent}(Consider upgrading to a late release of tcl 8.6 or tcl 9+ )" \n - append warningblock [a] - } - lappend chunks [list stdout $text] - } - env - environment { - set text "" - #todo - move to punk::config? - upvar ::punk::config::punk_env_vars_config punkenv_config - upvar ::punk::config::other_env_vars_config otherenv_config - - set known_punk [dict keys $punkenv_config] - set known_other [dict keys $otherenv_config] - append text \n - set usetable 1 - if {$usetable} { - set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] - $t configure -frametype $frametype - if {"windows" eq $::tcl_platform(platform)} { - #If any env vars have been set to empty string - this is considered a deletion of the variable on windows. - #The Tcl ::env array is linked to the underlying process view of the environment - #- but info exists ::env(var) can misreport as true if it has been deleted by setting to empty string rather than using unset. - #an 'array get' will resynchronise. - #Even if an env variable didn't exist before - setting it to empty string can get it to this inconsistent state. - array get ::env - } - #do an array read on ::env - foreach {v vinfo} $punkenv_config { - if {[info exists ::env($v)]} { - set c2 [set ::env($v)] - } else { - set c2 "(NOT SET)" - } - set help "" - if {[dict exists $vinfo help]} { - set help [dict get $vinfo help] - } - $t add_row [list $v $c2 $help] - } - $t configure_column 0 -headers [list "Punk environment vars"] - $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} - - set punktable [$t print] - $t destroy - - set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] - $t configure -frametype $frametype - foreach {v vinfo} $otherenv_config { - if {[info exists ::env($v)]} { - set env_val [set ::env($v)] - if {[string match "*_TM_PATH" $v]} { - set entries [split $env_val $::tcl_platform(pathSeparator)] - set c2 [join $entries \n] - } else { - set c2 $::env($v) - } - } else { - set c2 "(NOT SET)" - } - $t add_row [list $v $c2] - } - $t configure_column 0 -headers [list "Other environment vars"] - $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} - - set othertable [$t print] - $t destroy - #append text [textblock::join -- $punktable " " $othertable]\n - append text $punktable\n$othertable\n + set word0 [lindex $topicparts 0] + set topic [helptopic::resolve $word0] + if {$word0 eq ""} { + #no topic supplied - overview of key shell commands + lappend chunks {*}[helptopic::overview $context {*}[lrange $topicparts 1 end]] + } elseif {$topic ne ""} { + lappend chunks {*}[helptopic::$topic $context {*}[lrange $topicparts 1 end]] + } else { + #not a registered topic - fall through to basic command info lookup + set text "" + set cinfo [uplevel 1 [list ::punk::ns::cmdwhich [lindex $topicparts 0]]] + set wtype [dict get $cinfo whichtype] + if {$wtype eq "notfound"} { + set externalinfo [auto_execok [lindex $topicparts 0]] + if {[string length $externalinfo]} { + set text "$topicparts" + append text \n "Base type: External command" + append text \n "$externalinfo [lrange $topicparts 1 end]" } else { - - append text $linesep\n - append text "punk environment vars:\n" - append text $linesep\n - set col1 [string repeat " " 25] - set col2 [string repeat " " 50] - foreach v $known_punk { - set c1 [overtype::left $col1 $v] - if {[info exists ::env($v)]} { - set c2 [overtype::left $col2 [set ::env($v)]] - } else { - set c2 [overtype::right $col2 "(NOT SET)"] - } - append text "$c1 $c2\n" - } - append text $linesep\n + set text "$topicparts\n" + append text "No matching internal or external command found" } - - lappend chunks [list stdout $text] - } - console - term - terminal { - set term_env_vars {TERM TERM_PROGRAM TERM_PROGRAM_VERSION COLORTERM} - set term_dict [dict create] - foreach e $term_env_vars { - if {[info exists ::env($e)]} { - dict set term_dict $e [set ::env($e)] - } else { - dict set term_dict $e "(NOT SET)" - } - } - set text "Terminal environment variables:\n" - append text [punk::lib::showdict $term_dict] \n - lappend chunks [list stdout $text] - set text "" - set indent [string repeat " " [string length "WARNING: "]] - - 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 { - - if {![catch {punk::console::class_info} console_class_info]} { - set text "Terminal class info (from device secondary attributes query to terminal):\n" - append text [punk::lib::showdict $console_class_info] \n - } else { - set text "Unable to query terminal class info - err:$console_class_info\n" - } - lappend chunks [list stdout $text] - - 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" - } - } - 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" - } - - 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" - } - - - 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 posn [punk::console::get_cursor_pos] ;#warmup call - and test if works - if {$posn eq ""} { - append warningblock \n "WARNING: terminal doesn't respond to cursor position query - may cause display bugs in some cases." - } else { - set timeresult [timerate {set cpos [punk::console::get_cursor_pos]}] - lassign [split $cpos {;}] row col - if {![string is integer -strict $row] || ![string is integer -strict $col]} { - append warningblock \n "WARNING: terminal returns non-integer values for cursor position query - may cause display bugs in some cases. got row:'$row' col:'$col'" - } else { - set micros [lindex $timeresult 0] - if {$micros > 2000} { - append warningblock \n "WARNING: terminal cursor position query is very slow ($micros microseconds - expect < 2000us )" - append warningblock \n $indent "- may cause display lag/bugs in some cases." - } else { - if {$micros > 1000} { - set text "\n[a+ yellow]Terminal cursor position query test passed." - append text \n $indent "Response time: ${micros} microseconds (OK, good would be <= 1000us).[a]" - - } else { - set text "[a+ green]Terminal cursor position query test passed." - append text \n $indent "Response time: ${micros} microseconds (GOOD).[a]" - } - lappend chunks [list stdout $text] - } - } - } - - - if {![string length $warningblock]} { - set text "[a+ green]No terminal warnings[a]\n" - lappend chunks [list stdout $text] + } else { + set text "[dict get $cinfo which] [lrange $topicparts 1 end]" + append text \n "Base type: $wtype" + set synopsis [uplevel 1 [list ::punk::ns::synopsis {*}$topicparts]] + set synshow "" + foreach sline [split $synopsis \n] { + if {[regexp {\s*#.*} $sline]} { + append synshow [punk::ansi::a+ bold term-darkgreen Term-white]$sline[punk::ansi::a] \n } else { - set mode [punk::console::mode] - if {$mode eq "line"} { - append warningblock \n "Terminal appears to be in line mode. Consider switching to raw mode and re-testing (command: punk::console::mode raw)." - } + append synshow $sline \n } - puts stdout [punk::ansi::move_back 200] ;#hack for some horizontal position bugs where the above tests can leave the cursor in the wrong place for the next output. - #200 is arbitrary large number to move back enough to get to start of line. - } - } - topics - help { - set text "" - set topics [dict create {*}{ - "topics|help" "List help topics" - "tcl" "Tcl version warnings" - "env|environment" "punkshell environment vars" - "console|terminal" "Some console behaviour tests and warnings" - "*" "Try to find help on the topic as a command or external executable" - }] - - set t [textblock::class::table new -show_seps 0] - $t configure -frametype $frametype - $t add_column -headers [list "Topic"] - $t add_column - foreach {k v} $topics { - $t add_row [list $k $v] } - set widest0 [$t column_datawidth 0] - $t configure_column 0 -minwidth [expr {$widest0 + 4}] - append text \n [$t print] - - lappend chunks [list stdout $text] - } - default { - set text "" - set cinfo [uplevel 1 [list ::punk::ns::cmdwhich [lindex $topicparts 0]]] - set wtype [dict get $cinfo whichtype] - if {$wtype eq "notfound"} { - set externalinfo [auto_execok [lindex $topicparts 0]] - if {[string length $externalinfo]} { - set text "$topicparts" - append text \n "Base type: External command" - append text \n "$externalinfo [lrange $topicparts 1 end]" - } else { - set text "$topicparts\n" - append text "No matching internal or external command found" - } - } else { - set text "[dict get $cinfo which] [lrange $topicparts 1 end]" - append text \n "Base type: $wtype" - set synopsis [uplevel 1 [list ::punk::ns::synopsis {*}$topicparts]] - set synshow "" - foreach sline [split $synopsis \n] { - if {[regexp {\s*#.*} $sline]} { - append synshow [punk::ansi::a+ bold term-darkgreen Term-white]$sline[punk::ansi::a] \n - } else { - append synshow $sline \n - } - } - if {[string index $synshow end] eq "\n"} { - set synshow [string range $synshow 0 end-1] - } - append text \n $synshow + if {[string index $synshow end] eq "\n"} { + set synshow [string range $synshow 0 end-1] } - lappend chunks [list stdout $text] + append text \n $synshow } + lappend chunks [list stdout $text] } - - - lappend chunks [list stderr $warningblock] return $chunks } proc mode {{raw_or_line query}} { @@ -9298,7 +9350,7 @@ punkcheck::cli set_alias punkcheck package provide punk [namespace eval punk { #FUNCTL variable version - set version 0.1.1 + set version 0.2.0 }] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.3.tm similarity index 99% rename from src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm rename to src/vfs/_vfscommon.vfs/modules/punk/args-0.2.3.tm index 21ee1c6d..e8b2c3bf 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.3.tm @@ -8,7 +8,7 @@ # (C) 2024 # # @@ Meta Begin -# Application punk::args 0.2.1 +# Application punk::args 0.2.3 # Meta platform tcl # Meta license # @@ Meta End @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_punk::args 0 0.2.1] +#[manpage_begin punkshell_module_punk::args 0 0.2.3] #[copyright "2024"] #[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] #[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] @@ -871,19 +871,46 @@ tcl::namespace::eval punk::args { -choicerestricted Whether values not specified in -choices or -choicegroups are allowed. Defaults to true. + When false, an input that matches no choice - including an + ambiguous prefix, a prefix of a -choiceprefixdenylist entry, + or a -choiceprefixreservelist word - is accepted unchanged as + an ordinary value (subject to -type validation) instead of + raising an error. This passthrough is the pattern for + arguments that mix a known choice set with free-form values + (e.g. a help topic word falling through to command lookup). -choiceprefix This specifies whether unique prefixes are able to be used instead of the complete string. This is calculated using tcl::prefix::match - and will display in the autogenerated usage output. Defaults to true. + A matching prefix is normalized: the parse result contains + the full choice string, never the typed prefix - so callers + switch on canonical choice values only. The usage display + highlights each choice's minimal accepted prefix (a choice + in -choiceprefixdenylist displays fully highlighted - the + whole word is required). -choiceprefixdenylist {} These choices should match exactly a choice entry in one of the settings -choices or -choicegroups. These will still be used in prefix calculation - but the full choice argument must be entered to select the choice. + A shorter prefix of a denied choice is an error when + -choicerestricted is true, and passes through as an ordinary + (non-choice) value when -choicerestricted is false - use this + to keep short words available for other purposes (e.g. with + 'help' denied, h/he/hel remain free-form values). -choiceprefixreservelist {} These choices are additional values used in prefix calculation. The values will not be added to the list of available choices. + A reserved word never matches: entered exactly it is an error + when -choicerestricted is true and passes through when false, + as do any shorter words it shadows into ambiguity. This gives + per-choice control of the minimum accepted prefix by reserving + phantom entries: e.g. -choices {environment} + -choiceprefixreservelist {en} means e/en do not match while + env, envi, ... environment all normalize to environment. + (To require a longer minimum, reserve each shorter form: + reserving {en env} raises the minimum to envi.) -choicegroups {} Generally this would be used instead of -choices to allow usage display of choices grouped by some name (or the empty @@ -6156,7 +6183,7 @@ tcl::namespace::eval punk::args { #puts stderr ">>>_get_dict_can_assign_value idx:$idx v:[lindex $values $idx] consumed:$alloc_count thistype:$thistype" set d [dict create consumed $alloc_count resultlist $resultlist typelist $newtypelist] } else { - puts stderr ">>>_get_dict_can_assign_value NOT alloc_ok: idx:$idx v:[lindex $values $idx] consumed:$alloc_count thistype:$thistype" + #puts stderr ">>>_get_dict_can_assign_value NOT alloc_ok: idx:$idx v:[lindex $values $idx] consumed:$alloc_count thistype:$thistype" set d [dict create consumed 0 resultlist {} typelist $thistype] } #puts ">>>> _get_dict_can_assign_value $d" @@ -9835,7 +9862,10 @@ tcl::namespace::eval punk::args { set argname [dict get $lookup_optset $fullflag] #idents should already have correct parsekey } else { - puts stderr "punk::args::get_dict unable to find $fullflag in $lookup_optset (parsekey:$parsekey) (value_group: $value_group)" + #adhoc option (allowed via "@opts -any|-arbitrary true") - not in lookup_optset. + #argstate/arg_checks were populated for it under its raw supplied name at scan time. + set argname $fullflag + #puts stderr "punk::args::get_dict unable to find $fullflag in $lookup_optset (parsekey:$parsekey) (value_group: $value_group)" } } else { if {[dict exists $lookup_optset $argname_or_ident]} { @@ -9850,7 +9880,15 @@ tcl::namespace::eval punk::args { set parsekey [string trimright [lindex [split $argname |] end] =] } } else { - puts stderr "punk::args::get_dict unable to find $argname_or_ident in $lookup_optset (value_group: $value_group)" + #adhoc option (allowed via "@opts -any|-arbitrary true") - not in lookup_optset. + #argstate/arg_checks were populated for it under its raw supplied name at scan time. + set argname $argname_or_ident + if {$pkoverride ne ""} { + set parsekey $pkoverride + } else { + set parsekey [string trimright [lindex [split $argname |] end] =] + } + #puts stderr "punk::args::get_dict unable to find $argname_or_ident in $lookup_optset (value_group: $value_group)" } } } else { @@ -12357,7 +12395,7 @@ package provide punk::args [tcl::namespace::eval punk::args { tcl::namespace::path {::punk::args::lib ::punk::args::system} variable pkg punk::args variable version - set version 0.2.1 + set version 0.2.3 }] return diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.1.tm similarity index 99% rename from src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm rename to src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.1.tm index ad3cd57e..114d980b 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.1.tm @@ -7,7 +7,7 @@ # (C) 2023 # # @@ Meta Begin -# Application punk::ns 0.1.0 +# Application punk::ns 0.1.1 # Meta platform tcl # Meta license # @@ Meta End @@ -4633,7 +4633,7 @@ y" {return quirkykeyscript} set vline [punk::args::ensemble_subcommands_definition -columns 2 $origin] set autoid "(autodef)$origin" - puts "ENSEMBLE auto def $autoid (generate_autodef)" + #puts "ENSEMBLE auto def $autoid (generate_autodef)" #A namespace can contain spaces, so an ensemble command can contain spaces. We must quote the -id value in the autodef set argdef [punk::lib::tstr -return string { @id -id "${$autoid}" @@ -4699,7 +4699,7 @@ y" {return quirkykeyscript} append argdef \n "@formdisplay -body {$tepamhelp}" punk::args::define $argdef } else { - puts "PROC auto def $autoid (generate_autodef)" + #puts "PROC auto def $autoid (generate_autodef)" #to handle procs like ":" (eg used by colin's bytecode based expr replacement) or other names of the form ":xyz" #we can't use 'info args :::' - tcl won't find it set ns [nsprefix $origin] @@ -5026,7 +5026,7 @@ y" {return quirkykeyscript} if {[punk::args::id_exists "$origin [lindex $args $i]"]} { set a [lindex $args $i] #review - tests? - puts stderr "cmd_traverse - skipping to documented subcommand '$origin $a'" + #puts stderr "cmd_traverse - skipping to documented subcommand '$origin $a'" #we can only seek beyond an undocumented subcommand level via a space delimited path, as we can make no assumption about the actual location of a subcommand relative to its parent #There could be a different command at for example "${origin}::$a" which is unrelated to the actual resolution path. set docid_exists 1 @@ -5120,7 +5120,7 @@ y" {return quirkykeyscript} lappend resolvedargs $q lpop queryargs_untested 0 lappend eparams $q - puts stderr "---> cmd_traverse ensembleparam $q ($lname)" + #puts stderr "---> cmd_traverse ensembleparam $q ($lname)" #puts stderr "arginfo: $arginfo" #puts stderr "---> eparams: $eparams" #puts stderr "---> existing args: $args" @@ -5304,7 +5304,7 @@ y" {return quirkykeyscript} } } #REVIEW!!! - puts stderr "cmd_traverse 10 $origin $resolvedargs $queryargs_untested $docid - review" + #puts stderr "cmd_traverse 10 $origin $resolvedargs $queryargs_untested $docid - review" return [list 10 $origin $resolvedargs $queryargs_untested $docid] } @@ -7591,6 +7591,6 @@ namespace eval ::punk::args::register { ## Ready package provide punk::ns [tcl::namespace::eval punk::ns { variable version - set version 0.1.0 + set version 0.1.1 }] return \ No newline at end of file