diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index 1a642c70..5045579b 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -496,23 +496,25 @@ namespace eval punk { #----------------------------------------------------------------------------------- #get a copy of the item without affecting internal rep - proc objclone {obj} { + proc valcopy {obj} { append obj2 $obj {} } - proc set_clone {varname obj} { - #maintenance: also punk::lib::set_clone - #e.g used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_clone varnmame $val] + + + proc set_valcopy {varname obj} { + #maintenance: also punk::lib::set_valcopy + #e.g used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_valcopy varnmame $val] append obj2 $obj {} uplevel 1 [list set $varname $obj2] } interp alias "" strlen "" ::punk::strlen interp alias "" str_len "" ::punk::strlen - interp alias "" objclone "" ::punk::objclone + interp alias "" valcopy "" ::punk::valcopy #proc ::strlen {str} { # string length [append str2 $str {}] #} - #proc ::objclone {obj} { + #proc ::valcopy {obj} { # append obj2 $obj {} #} @@ -629,10 +631,24 @@ namespace eval punk { -- -type none @values pattern -type string -help\ - "regex pattern to match in plaintext portion of ANSI string + {regex pattern to match in plaintext portion of ANSI string The pattern may contain bracketed capturing groups, which - will be highlighted (todo) in the result. If there is no capturing - group, the entire match will be highlighted." + will be highlighted in the result. If there is no capturing + group, the entire match will be highlighted. + + Note that if we were to attempt to highlight curly braces based + on the regexp {\{|\}} then the inserted ansi would come between + the backslash and brace in cases where a curly brace is escaped + ie \{ or \} + Depending on how the output is used, this can break the syntactic + structure causing problems. + Instead a pair of regexes such as + {^\{|[^\\](\{+)} + {[^\\](\}+)} + should be used to + exclude braces that are escaped. + (note the capturing groups around each curly brace) + } string -type string } proc grepstr {args} { @@ -706,9 +722,12 @@ namespace eval punk { } if {$lineindex in $matched_line_indices} { set plain_ln [lindex $plainlines $lineindex] - #first test the regexp with a single match to determine number of capturing groups - set matchparts [regexp {*}$nocase -inline -- $pattern $plain_ln] ;#get fullmatch capturegroup... - set numgroups [expr {[llength $matchparts] -1}] + #first - determine the number of capturing groups (subexpressions) + #option 1: test the regexp with a single match + #set testparts [regexp {*}$nocase -inline -- $pattern $plain_ln] ;#get fullmatch capturegroup... + #set numgroups [expr {[llength $testparts] -1}] + #option 2: use the regexp -about flag + set numgroups [lindex [regexp -about $pattern] 0] set allparts [regexp -all {*}$nocase -indices -inline -- $pattern $plain_ln] #allparts includes each full match as well as each capturing group @@ -730,9 +749,14 @@ namespace eval punk { # restrict ourself to just the capture groups, excluding the full match (if there are capture groups) set highlight_ranges [list] set i 0 + #{-1 -1} returned for non-matching group when there are capture-group alternatives + #e.g {(a)|(b)} foreach range $allparts { if {($i % ($numgroups+1)) != 0} { - lappend highlight_ranges $range + lassign $range a b + if {$range ne {-1 -1} & $a <= $b} { + lappend highlight_ranges $range + } } incr i } @@ -917,10 +941,8 @@ namespace eval punk { return [twapi::new_uuid] } } - - #get last command result that was run through the repl - proc ::punk::get_runchunk {args} { - set argd [punk::args::parse $args withdef { + namespace eval argdoc { + punk::args::define { @id -id ::punk::get_runchunk @cmd -name "punk::get_runchunk" -help\ "experimental" @@ -928,7 +950,19 @@ namespace eval punk { -1 -optional 1 -type none -2 -optional 1 -type none @values -min 0 -max 0 - }] + } + } + #get last command result that was run through the repl + proc ::punk::get_runchunk {args} { + #set argd [punk::args::parse $args withdef { + # @id -id ::punk::get_runchunk + # @cmd -name "punk::get_runchunk" -help\ + # "experimental" + # @opts + # -1 -optional 1 -type none + # -2 -optional 1 -type none + # @values -min 0 -max 0 + #}] #todo - make this command run without truncating previous runchunks set runchunks [tsv::array names repl runchunks-*] @@ -4148,7 +4182,7 @@ namespace eval punk { #pipealias should capture the namespace context of the pipeline so that commands are resolved in the namespace in which the pipealias is created proc pipealias {targetcmd args} { - set cmdcopy [punk::objclone $args] + set cmdcopy [punk::valcopy $args] set nscaller [uplevel 1 [list namespace current]] tailcall interp alias {} $targetcmd {} apply [list args [append cmdcopy " {*}\$args"] $nscaller] } @@ -4159,7 +4193,7 @@ namespace eval punk { } #although the pipealias2 'concat' alias is cleaner in that the original pipeline can be extracted using list commands - it runs much slower proc pipealias2 {targetcmd args} { - set cmdcopy [punk::objclone $args] + set cmdcopy [punk::valcopy $args] set nscaller [uplevel 1 [list namespace current]] tailcall interp alias {} $targetcmd {} apply [list args [concat "\[concat" [list $cmdcopy] "\$args]"] $nscaller] } @@ -6654,15 +6688,16 @@ namespace eval punk { #interp alias {} ~ {} file join $::env(HOME) ;#HOME must be capitalized to work cross platform (lowercase home works on windows - but probably not elsewhere) #interp alias {} ~ {} apply {args {file join $::env(HOME) $args}} proc ~ {args} { - set hdir [punk::objclone $::env(HOME)] + set hdir [punk::valcopy $::env(HOME)] file pathtype $hdir set d $hdir #use the file join 2-arg optimisation to avoid losing path-rep - probably doesn't give any advantage on all Tcl versions + #review - for what versions does/did the 2-arg version of file join not just return a string? foreach a $args { set d [file join $d $a] } file pathtype $d - return [punk::objclone $d] + return [punk::valcopy $d] } interp alias {} ~ {} punk::~ @@ -7789,47 +7824,61 @@ namespace eval punk { + namespace eval argdoc { + 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 + } + } + proc help {args} { + set chunks [uplevel 1 [list ::punk::help_chunks {*}$args]] + foreach chunk $chunks { + lassign $chunk chan text + puts -nonewline $chan $text + } + } #return list of {chan chunk} elements proc help_chunks {args} { - set chunks [list] - set linesep [string repeat - 76] - set mascotblock "" - catch { - package require patternpunk - #lappend chunks [list stderr [>punk . rhs]] - append mascotblock [textblock::frame -checkargs 0 [>punk . banner -title "Punk Shell" -left Tcl -right [package provide Tcl]]] + set argd [punk::args::parse $args withid ::punk::help_chunks] + lassign [dict values $argd] leaders opts values received + if {[dict exists $values arg]} { + set topicparts [dict get $values arg] + } else { + set topicparts [list ""] } + #set topic [lindex $args end] + #set argopts [lrange $args 0 end-1] - set topic [lindex $args end] - set argopts [lrange $args 0 end-1] + set chunks [list] + set linesep [string repeat - 76] + + set warningblock "" - set title "[a+ brightgreen] Punk core navigation commands: " + set I [punk::ansi::a+ italic] + set NI [punk::ansi::a+ noitalic] - #todo - load from source code annotation? + # ------------------------------------------------------- + set logoblock "" + if {[catch { + package require patternpunk + #lappend chunks [list stderr [>punk . rhs]] + append logoblock [textblock::frame -title "Punk Shell [package provide punk]" -width 29 -checkargs 0 [>punk . banner -title "" -left Tcl -right [package provide Tcl]]] + }]} { + append logoblock [textblock::frame -title "Punk Shell [package provide punk]" -subtitle "TCL [package provide Tcl]" -width 29 -height 10 -checkargs 0 ""] + } + set title "[a+ brightgreen] Help System: " set cmdinfo [list] - lappend cmdinfo [list help "?topics?" "This help. To see available subitems type: help topics"] - lappend cmdinfo [list i "cmd ?subcommand...?" "Show usage for a command or ensemble subcommand"] - lappend cmdinfo [list s "cmd ?subcommand...?" "Show synopsis for a command or ensemble subcommand"] - lappend cmdinfo [list eg "cmd ?subcommand...?" "Show example from manpage"] - lappend cmdinfo [list ./ "?subdir?" "view/change directory"] - lappend cmdinfo [list ../ "" "go up one directory"] - lappend cmdinfo [list ./new "subdir" "make new directory and switch to it"] - lappend cmdinfo [list n/ "?glob...?" "view/change namespace\n (accepts ns path globs e.g **::*get* to match comands at any level )"] - lappend cmdinfo [list n// "" "view/change namespace (with command listing)"] - lappend cmdinfo [list "nn/" "" "go up one namespace"] - lappend cmdinfo [list "n/new" "" "make child namespace and switch to it"] - lappend cmdinfo [list dev "?subcommand?" "(ensemble command to make new projects/modules and to generate docs)"] - lappend cmdinfo [list a? "?subcommand...?" "view ANSI colours\n e.g a? web"] - - #set cmds [lsearch -all -inline -index 0 -subindices $cmdinfo *] - #set descr [lsearch -all -inline -index 1 -subindices $cmdinfo *] - #set widest1 [tcl::mathfunc::max {*}[lmap v $cmds {string length $v}]] - #set widest2 [tcl::mathfunc::max {*}[lmap v $descr {string length $v}]] - set t [textblock::class::table new -show_seps 0] - #foreach c $cmds d $descr { - # $t add_row [list $c $d] - #} + lappend cmdinfo [list help "?${I}topic${NI}?" "This help.\nTo see available subitems type:\nhelp topics\n\n\n\n\n"] + set t [textblock::class::table new -minwidth 51 -show_seps 0] foreach row $cmdinfo { $t add_row $row } @@ -7838,272 +7887,387 @@ namespace eval punk { 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] - - - set warningblock "" - set introblock $mascotblock - append introblock \n $text - - #if {[catch {package require textblock} errM]} { - # append warningblock \n "WARNING: textblock package couldn't be loaded. Side-by-side display not available" - #} else { - # set introblock [textblock::join -- " " \n$mascotblock " " $text] - #} - - - lappend chunks [list stdout $introblock] - - - if {$topic in [list tcl]} { - if {[punk::lib::check::has_tclbug_script_var]} { - append warningblock \n "minor warning: punk::lib::check::has_tclbug_script_var returned true! (string rep for list variable in script generated when script changed)" - } - if {[punk::lib::check::has_tclbug_safeinterp_compile]} { - set indent " " - append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_safeinterp returned true!" \n - append warningblock "${indent}(ensemble commands not compiled in safe interps - heavy performance impact in safe interps)" \n - append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/1095bf7f75]" - append warningblock [a] - } - if {[catch {lsearch -stride 2 {a b} b}]} { - 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] - } else { - if {[punk::lib::check::has_tclbug_lsearch_strideallinline]} { + set text [$t print] + + 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}subdir${NI}?" "view/change directory"] + lappend cmdinfo [list ../ "" "go up one directory"] + lappend cmdinfo [list ./new "${I}subdir${NI}" "make new directory and switch to it"] + set t [textblock::class::table new -minwidth 80 -show_seps 0] + 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 "n/new" "${I}ns${NI}" "make child namespace and switch to it"] + set t [textblock::class::table new -minwidth 80 -show_seps 0] + foreach row $cmdinfo { + $t add_row $row + } + 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"] + set t [textblock::class::table new -minwidth 80 -show_seps 0] + 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] + 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]" + } + if {[punk::lib::check::has_tclbug_script_var]} { + append warningblock \n "minor warning: punk::lib::check::has_tclbug_script_var returned true! (string rep for list variable in script generated when script changed)" + } + if {[punk::lib::check::has_tclbug_safeinterp_compile]} { set indent " " - append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_lsearch_strideallinline returned true!" \n - append warningblock "${indent}(lsearch using -stride -all -inline -subindices does not return values corresponding to subindex when a single -index value is used)" \n - append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/5a1aaa201d]" + append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_safeinterp returned true!" \n + append warningblock "${indent}(ensemble commands not compiled in safe interps - heavy performance impact in safe interps)" \n + append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/1095bf7f75]" append warningblock [a] } - } - if {[punk::lib::check::has_tclbug_list_quoting_emptyjoin]} { - set indent " " - append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_list_quoting returned true!" \n - append warningblock "${indent}lists elements not properly quoted in some cases. e.g 'list {*}[lindex {etc #foo} 1] {*}[list]' (#foo not braced)" \n - append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/e38dce74e2]" - } - } - - set text "" - if {$topic in [list env environment]} { - #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]] - 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] + if {[catch {lsearch -stride 2 {a b} b}]} { + 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] + } else { + if {[punk::lib::check::has_tclbug_lsearch_strideallinline]} { + set indent " " + append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_lsearch_strideallinline returned true!" \n + append warningblock "${indent}(lsearch using -stride -all -inline -subindices does not return values corresponding to subindex when a single -index value is used)" \n + append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/5a1aaa201d]" + append warningblock [a] } - $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} + if {[punk::lib::check::has_tclbug_list_quoting_emptyjoin]} { + set indent " " + append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_list_quoting returned true!" \n + append warningblock "${indent}lists elements not properly quoted in some cases. e.g 'list {*}[lindex {etc #foo} 1] {*}[list]' (#foo not braced)" \n + append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/e38dce74e2]" + } + 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]] + 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 punktable [$t print] + $t destroy - set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] - 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] + set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] + 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 $::env($v) + set c2 "(NOT SET)" } - } else { - set c2 "(NOT SET)" + $t add_row [list $v $c2] } - $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} + $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 { + 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] - } - - if {$topic in [list console terminal]} { - set indent [string repeat " " [string length "WARNING: "]] - lappend cstring_tests [dict create\ - type "PM "\ - msg "UN"\ - f7 punk::ansi::controlstring_PM\ - f7prefix "7bit ESC ^ secret "\ - f7suffix "safe"\ - f8 punk::ansi::controlstring_PM8\ - f8prefix "8bit \\x9e secret "\ - f8suffix "safe"\ - ] - lappend cstring_tests [dict create\ - type SOS\ - msg "NOT"\ - f7 punk::ansi::controlstring_SOS\ - f7prefix "7bit ESC X string "\ - f7suffix " hidden"\ - f8 punk::ansi::controlstring_SOS8\ - f8prefix "8bit \\x98 string "\ - f8suffix " hidden"\ - ] - lappend cstring_tests [dict create\ - type APC\ - msg "NOT"\ - f7 punk::ansi::controlstring_APC\ - f7prefix "7bit ESC _ APPLICATION PROGRAM COMMAND "\ - f7suffix " hidden"\ - f8 punk::ansi::controlstring_APC8\ - f8prefix "8bit \\x9f APPLICATION PROGRAM COMMAND "\ - f8suffix " hidden"\ - ] - - 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]" + 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] + } + console - term - terminal { + set indent [string repeat " " [string length "WARNING: "]] + lappend cstring_tests [dict create\ + type "PM "\ + msg "UN"\ + f7 punk::ansi::controlstring_PM\ + f7prefix "7bit ESC ^ secret "\ + f7suffix "safe"\ + f8 punk::ansi::controlstring_PM8\ + f8prefix "8bit \\x9e secret "\ + f8suffix "safe"\ + ] + lappend cstring_tests [dict create\ + type SOS\ + msg "NOT"\ + f7 punk::ansi::controlstring_SOS\ + f7prefix "7bit ESC X string "\ + f7suffix " hidden"\ + f8 punk::ansi::controlstring_SOS8\ + f8prefix "8bit \\x98 string "\ + f8suffix " hidden"\ + ] + lappend cstring_tests [dict create\ + type APC\ + msg "NOT"\ + f7 punk::ansi::controlstring_APC\ + f7prefix "7bit ESC _ APPLICATION PROGRAM COMMAND "\ + f7suffix " hidden"\ + f8 punk::ansi::controlstring_APC8\ + f8prefix "8bit \\x9f APPLICATION PROGRAM COMMAND "\ + f8suffix " hidden"\ + ] + + 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 {$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]" + } + 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" } - append warningblock \n "WARNING: terminal doesn't hide all [dict get $test type] control strings: $d $d8" + } else { + append warningblock \n "WARNING: terminal unable to check for legacysymbolwidth bug. err:$result" } - } - if {![catch {punk::console::check::has_bug_legacysymbolwidth} result]} { - if {$result} { - append warningblock \n "WARNING: terminal has legacysymbolwidth bug - screen position for symbol reports 2 wide but displays 1 wide." - append warningblock \n $indent "Layout using 'legacy symbols for computing' affected." - append warningblock \n $indent "(e.g textblock frametype block2 unsupported)" - append warningblock \n $indent "This can cause extreme layout deformation when ANSI is present" - append warningblock \n $indent "In some cases unwanted spacing effects occur at a distance from the characters causing it" + + if {![catch {punk::console::check::has_bug_zwsp} result]} { + if {$result} { + append warningblock \n "WARNING: terminal has zero width space (\\u200b) bug - cursor position incremented when it shouldn't be." + append warningblock \n $indent "The zwsp may or may not be displayed. zwsp contributes to line length and wrapping point" + } + } else { + append warningblock \n "WARNING: terminal unable to check for zwsp bug. err:$result" } - } else { - append warningblock \n "WARNING: terminal unable to check for 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" + + set grapheme_support [punk::console::grapheme_cluster_support] + #mode, 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) + if {![dict size $grapheme_support] || [dict get $grapheme_support mode] eq "unsupported" } { + append warningblock \n "WARNING: terminal either doesn't support grapheme clusters, or doesn't report so via decmode 2027 query." + if {[dict size $grapheme_support] && [dict get $grapheme_support available]} { + append warningblock \n $indent "(but punk::console::grapheme_cluster_support has determined it is probably available)" + } + } else { + if {![dict get $grapheme_support available]} { + switch -- [dict get $grapheme_support mode] { + "unset" { + append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is off." + } + "permanently_unset" { + append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is permanently off." + } + "BAD_RESPONSE" { + append warningblock \n "WARNING: terminal doesn't seem to recognize decmode 2027 query. No grapheme cluster support." + } + } + } + } + if {![string length $warningblock]} { + set text "No terminal warnings\n" + lappend chunks [list stdout $text] } - } else { - append warningblock \n "WARNING: terminal unable to check for zwsp bug. err:$result" } + 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"\ + ] - - 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)" + set t [textblock::class::table new -show_seps 0] + $t add_column -headers [list "Topic"] + $t add_column + foreach {k v} $topics { + $t add_row [list $k $v] } - } 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 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 } + lappend chunks [list stdout $text] } - } - lappend chunks [list stderr $warningblock] - if {$topic in [list 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"\ - ] - - set t [textblock::class::table new -show_seps 0] - $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] - } + lappend chunks [list stderr $warningblock] return $chunks } - proc help {args} { - set chunks [help_chunks {*}$args] - foreach chunk $chunks { - lassign $chunk chan text - puts -nonewline $chan $text - } - } proc mode {{raw_or_line query}} { package require punk::console tailcall ::punk::console::mode $raw_or_line diff --git a/src/modules/punk/ansi-999999.0a1.0.tm b/src/modules/punk/ansi-999999.0a1.0.tm index 1f52be5a..540f3307 100644 --- a/src/modules/punk/ansi-999999.0a1.0.tm +++ b/src/modules/punk/ansi-999999.0a1.0.tm @@ -340,6 +340,28 @@ tcl::namespace::eval punk::ansi::class { } } +tcl::namespace::eval punk::ansi { + namespace eval argdoc { + variable PUNKARGS + # -- --- --- --- --- + #non colour SGR codes + # we can use these directly via ${$I} etc without marking a definition with @dynamic + #This is because they don't need to change when colour switched on and off. + #chicken/egg - need to use literals here + set I "\x1b\[3m" ;# [a+ italic] + set NI "\x1b\[23m" ;# [a+ noitalic] + set B "\x1b\[1m" ;# [a+ bold] + set N "\x1b\[22m" ;# [a+ normal] + set T "\x1b\[1\;4m" ;# [a+ bold underline] + set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline] + set LC \u007b ;#left curly brace + set RC \u007d ;#right curly brace + # -- --- --- --- --- + + #namespace import ::punk::args::helpers::* + + } +} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::ansi { @@ -2262,59 +2284,74 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu return $displaytable } - lappend PUNKARGS [list { - @id -id ::punk::ansi::a? - @cmd -name "punk::ansi::a?"\ - -summary\ - "ANSI colour information"\ - -help\ - "" - @form -form "sgr_overview" - @values -form "sgr_overview" -min 0 -max 0 - - - @form -form "term" - @leaders -form "term" -min 1 -max 1 - term -type literal(term) -help\ - "256 term colours" - @opts -min 0 -max 0 - @values -form "term" -min 0 -max -1 - panel -type string -optional 1 -multiple 1 -default {16 main greyscale note}\ - -choices {16 main greyscale pastel rainbow note} - - @form -form "tk" - @leaders -form "tk" -min 1 -max 1 - tk -type literal(tk)|literal(TK) -help\ - "Tk colours" - @opts -form "tk" - -merged -type none -help\ - "If this flag is supplied - show colour names with the same RGB - values together." - @values -form "tk" -min 0 -max -1 - glob -type string -optional 1 -multiple 1 -help\ - "A glob string such as *green*. - Multiple glob entries can be provided. The search is case insensitive" - - - @form -form "web" - @values -form "web" -min 1 -max -1 - web -type literal(web) -help\ - "Web colours" - panel -type string -optional 1 -multiple 1 -choices {basic pink red orange yellow brown purple blue cyan green white gray} - - @form -form "x11" - @values -form "x11" -min 1 -max 1 - x11 -type literal(x11) -help\ - "x11 colours" - - - @form -form "sample" - @values -form "sample" -min 1 -max -1 - colourcode -type sgr|Sgr|literalprefix(term-)|literalprefix(Term-)|literalprefix(web-)|literalprefix(Web-)|literalprefix(rgb)|literalprefix(Rgb)\ - -optional 0\ - -multiple 1 - - }] + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::ansi::a? + @cmd -name "punk::ansi::a?"\ + -summary\ + "ANSI colour information"\ + -help\ + "With no arguments - display an overview information panel. + + With the first argument one of: + ${$B}term tk TK web x11${$N} + Display a more specific panel of colour information. + + With arguments of individual colourcodes from any of the above + sets, display a small diagnostic table showing a sample of + the individual and combined effect(s), along with indications + of the raw ANSI codes." + @form -form "sgr_overview" + @values -form "sgr_overview" -min 0 -max 0 + + + @form -form "term" + @leaders -form "term" -min 1 -max 1 + term -type literal(term) -help\ + "256 term colours" + @opts -min 0 -max 0 + @values -form "term" -min 0 -max -1 + panel -type string -optional 1 -multiple 1 -default {16 main greyscale note}\ + -choices {16 main greyscale pastel rainbow note} + + @form -form "tk" + @leaders -form "tk" -min 1 -max 1 + tk -type literal(tk)|literal(TK) -help\ + "Tk colours" + @opts -form "tk" + -merged -type none -help\ + "If this flag is supplied - show colour names with the same RGB + values together." + @values -form "tk" -min 0 -max -1 + glob -type string -optional 1 -multiple 1 -help\ + "A glob string such as *green*. + Multiple glob entries can be provided. The search is case insensitive" + + + @form -form "web" + @values -form "web" -min 1 -max -1 + web -type literal(web) -help\ + "Web colours" + panel -type string -optional 1 -multiple 1 -choices {basic pink red orange yellow brown purple blue cyan green white gray} + + @form -form "x11" + @values -form "x11" -min 1 -max 1 + x11 -type literal(x11) -help\ + "x11 colours" + + + @form -form "sample" + @values -form "sample" -min 1 -max -1 + #review literalprefix is not the right thing here! (literalprefix means a tcl::prefix::match on the value) + #colourcode -type sgr|Sgr|stringstartswith(term-)|stringstartswith(Term-)|stringstartswith(web-)|stringstartswith(Web-)|stringstartswith(rgb)|stringstartswith(Rgb) + colourcode -type string|stringstartswith(term-)|stringstartswith(Term-)|stringstartswith(web-)|stringstartswith(Web-)|stringstartswith(rgb)|stringstartswith(Rgb)\ + -typesynopsis {${$I}sgr${$NI}|${$I}Sgr${$NI}|${$I}colourcode${$NI}}\ + -optional 0\ + -multiple 1 + + }] + } proc a? {args} { #*** !doctools #[call [fun a?] [opt {ansicode...}]] @@ -2414,8 +2451,8 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu append out \n append out "[a+ {*}$fc web-white]Combination testing[a]" \n append out [textblock::join -- $indent "Example: a? red brightgreen underline Tk-slategrey italic"] \n - append out [textblock::join -- $indent "This will show a small table of each applied code and a RESULT row. The 'red' in this case is redundant,"] \n - append out [textblock::join -- $indent "so a final MERGED row displays with an alert 'REDUNDANCIES FOUND'."] \n + append out [textblock::join -- $indent "This will show a small table of each applied code and a RESULT row. The 'red' in this case is redundant, because there are"] \n + append out [textblock::join -- $indent "two foreground colours (lowercase first letter) so a final MERGED row displays with an alert 'REDUNDANCIES FOUND'."] \n append out [textblock::join -- $indent "The final columns of RESULT and MERGED (showing raw ANSI sequence) will differ if the arguments aren't in canonical order."] \n append out [textblock::join -- $indent "The MERGED line will only display if there are redundancies or different ordering."] \n @@ -2674,14 +2711,26 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } else { set tkcolours [list] } - foreach c $webcolours { - append info \n web-$c - } - foreach c $x11colours { - append info \n x11-$c - } - foreach c $tkcolours { - append info \n tk-$c + if {[string is upper -strict [string index $pfx 0]]} { + foreach c $webcolours { + append info \n Web-$c + } + foreach c $x11colours { + append info \n X11-$c + } + foreach c $tkcolours { + append info \n Tk-$c + } + } else { + foreach c $webcolours { + append info \n web-$c + } + foreach c $x11colours { + append info \n x11-$c + } + foreach c $tkcolours { + append info \n tk-$c + } } $t add_row [list $i "$info" $s [ansistring VIEW $s]] } @@ -8723,7 +8772,7 @@ interp alias {} ansistring {} ::punk::ansi::ansistring namespace eval ::punk::args::register { #use fully qualified so 8.6 doesn't find existing var in global namespace - lappend ::punk::args::register::NAMESPACES ::punk::ansi ::punk::ansi::class ::punk::ansi::ta + lappend ::punk::args::register::NAMESPACES ::punk::ansi ::punk::ansi::argdoc ::punk::ansi::class ::punk::ansi::ta } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index a26b98c7..e449c6b8 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -359,16 +359,22 @@ tcl::namespace::eval ::punk::args::helpers { #puts $str #puts stderr ------------------- - #rudimentary colourising (not full tcl syntax parsing) - #highlight comments first - so that we can also highlight braces within comments to help with detecting unbalanced braces/square brackets in comments switch -- $opt_syntax { tcl { + #rudimentary colourising (not full tcl syntax parsing) + #Note that this can highlight ;# in some places as a comment where it's not appropriate + # e.g inside a regexp + + #highlight comments first - so that we can also highlight braces within comments to help with detecting unbalanced braces/square brackets in comments #result lines often indicated in examples by \u2192 → #however - it's not present on each line of output, instead indents are used - so we can't so easily highlight all appropriate rows(?) set str [punk::grepstr -return all -highlight {Term-grey term-darkgreen} {^\s*#.*} $str] ;#Note, will not highlight comments at end of line - like this one set str [punk::grepstr -return all -highlight {Term-grey term-darkgreen} {;\s*(#.*)} $str] - #TODO - fix grepstr highlighting (bg issues - why?) - set str [punk::grepstr -return all -highlight {Term-grey term-darkblue} {\{|\}} $str] + + #Note that if we were to highlight based on the regexp {\{|\}} then the inserted ansi would come between + # the backslash and brace in \{ or \} - this breaks the syntactic structure causing problems. + set str [punk::grepstr -return all -highlight {Term-grey tk-darkblue} {^\{|[^\\](\{+)} $str] + set str [punk::grepstr -return all -highlight {Term-grey tk-darkblue} {[^\\](\}+)} $str] set str [punk::grepstr -return all -highlight {Term-grey term-orange1} {\[|\]} $str] #puts stderr ------------------- #puts $str @@ -460,7 +466,7 @@ tcl::namespace::eval ::punk::args::helpers { tcl::namespace::eval punk::args { package require punk::assertion #if 'package forget' was called on this package (e.g when loading test::punk::args) then assert may already exist in the namespace - #procs can be overridden silently, but not imports + #namespace import will fail if target exists catch { namespace import ::punk::assertion::assert } @@ -469,9 +475,9 @@ tcl::namespace::eval punk::args { variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. tcl::namespace::export {[a-z]*} - variable rawdef_cache - if {![info exists rawdef_cache]} { - set rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} + variable rawdef_cache_about + if {![info exists rawdef_cache_about]} { + set rawdef_cache_about [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} } variable id_cache_rawdef if {![info exists id_cache_rawdef]} { @@ -487,9 +493,9 @@ tcl::namespace::eval punk::args { set argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) } - variable argdata_cache - if {![info exists argdata_cache]} { - set argdata_cache [tcl::dict::create] + variable rawdef_cache_argdata + if {![info exists rawdef_cache_argdata]} { + set rawdef_cache_argdata [tcl::dict::create] } variable id_counter @@ -979,11 +985,11 @@ tcl::namespace::eval punk::args { error todo } proc define {args} { - variable rawdef_cache + variable rawdef_cache_about variable id_cache_rawdef - variable argdata_cache - if {[dict exists $rawdef_cache $args]} { - return [dict get [dict get $rawdef_cache $args] -id] + #variable rawdef_cache_argdata + if {[dict exists $rawdef_cache_about $args]} { + return [dict get [dict get $rawdef_cache_about $args] -id] } else { set lvl 2 set id [rawdef_id $args $lvl] @@ -991,46 +997,40 @@ tcl::namespace::eval punk::args { #we seem to be re-creating a previously defined id... #clear any existing caches for this id undefine $id 0 - - ##dict unset argdata_cache $prevraw ;#silently does nothing if key not present - #dict for {k v} $argdata_cache { - # if {[dict get $v id] eq $id} { - # dict unset argdata_cache $k - # } - #} - #dict for {k v} $rawdef_cache { - # if {[dict get $v -id] eq $id} { - # dict unset rawdef_cache $k - # } - #} - #dict unset id_cache_rawdef $id } set is_dynamic [rawdef_is_dynamic $args] set defspace [uplevel 1 {::namespace current}] - dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic -defspace $defspace] + dict set rawdef_cache_about $args [dict create -id $id -dynamic $is_dynamic -defspace $defspace] dict set id_cache_rawdef $id $args return $id } } proc undefine {id {quiet 0}} { - variable rawdef_cache + #review - alias? + variable rawdef_cache_about variable id_cache_rawdef - variable argdata_cache + variable rawdef_cache_argdata if {[id_exists $id]} { if {!$quiet} { puts stderr "punk::args::undefine clearing existing data for id:$id" } - dict for {k v} $argdata_cache { - if {[dict get $v id] eq $id} { - dict unset argdata_cache $k + if {[dict exists $id_cache_rawdef $id]} { + set deflist [dict get $id_cache_rawdef $id] + dict unset rawdef_cache_about $deflist + dict unset rawdef_cache_argdata $deflist + dict unset id_cache_rawdef $id + } else { + dict for {k v} $rawdef_cache_argdata { + if {[dict get $v id] eq $id} { + dict unset rawdef_cache_argdata $k + } } - } - dict for {k v} $rawdef_cache { - if {[dict get $v -id] eq $id} { - dict unset rawdef_cache $k + dict for {k v} $rawdef_cache_about { + if {[dict get $v -id] eq $id} { + dict unset rawdef_cache_about $k + } } } - dict unset id_cache_rawdef $id } else { if {!$quiet} { puts stderr "punk::args::undefine unable to find id: '$id'" @@ -1039,17 +1039,26 @@ tcl::namespace::eval punk::args { } #'punk::args::parse $args withdef $deflist' can raise parsing error after an autoid was generated # In this case we don't see the autoid in order to delete it - #proc undefine_deflist {deflist} { - #} + proc undefine_deflist {deflist} { + variable rawdef_cache_about + variable id_cache_rawdef + variable rawdef_cache_argdata + if {[dict exists $rawdef_cache_about $deflist -id]} { + set id [dict get $rawdef_cache_about $deflist -id] + dict unset rawdef_cache_about $deflist + dict unset rawdef_cache_argdata $deflist + dict unset id_cache_rawdef $id + } + } proc idquery_info {id} { variable id_cache_rawdef - variable rawdef_cache + variable rawdef_cache_about if {[dict exists $id_cache_rawdef $id]} { set sep [string repeat - 40] set rawdef [dict get $id_cache_rawdef $id] - if {[dict exists $rawdef_cache $rawdef]} { - set idinfo [dict get $rawdef_cache $rawdef] + if {[dict exists $rawdef_cache_about $rawdef]} { + set idinfo [dict get $rawdef_cache_about $rawdef] } else { set idinfo "" } @@ -1060,11 +1069,11 @@ tcl::namespace::eval punk::args { append result \n "id info:" append result \n $idinfo append result \n $sep - variable argdata_cache + variable rawdef_cache_argdata #lsearch -stride not avail (or buggy) in some 8.6 interps - search manually for now (2025). todo - modernize some time after Tcl 9.0/9.1 more widespread.(2027?) #check for and report if id is present multiple times set argdata_records [list] - dict for {k v} $argdata_cache { + dict for {k v} $rawdef_cache_argdata { if {[dict get $v id] eq $id} { if {$k eq $rawdef} { lappend argdata_records [list 1 $k $v] @@ -1100,12 +1109,20 @@ tcl::namespace::eval punk::args { dict get [resolve {*}$args] id } + lappend PUNKARGS [list { + @id -id ::punk::args::resolve + @cmd -name punk::args::resolve -help\ + "" + @values -min 0 -max -1 + arg -type any -multiple 1 -help\ + "rawdef line block" + }] proc resolve {args} { - variable rawdef_cache + variable rawdef_cache_about variable id_cache_rawdef set defspace "" - if {[dict exists $rawdef_cache $args]} { - set cinfo [dict get $rawdef_cache $args] + if {[dict exists $rawdef_cache_about $args]} { + set cinfo [dict get $rawdef_cache_about $args] set id [dict get $cinfo -id] set is_dynamic [dict get $cinfo -dynamic] if {[dict exists $cinfo -defspace]} { @@ -1116,12 +1133,13 @@ tcl::namespace::eval punk::args { set id [rawdef_id $args] puts stderr "Warning: punk::args::resolve called with undefined id:$id" set is_dynamic [rawdef_is_dynamic $args] - dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] + #-defspace ??? + dict set rawdef_cache_about $args [dict create -id $id -dynamic $is_dynamic] dict set id_cache_rawdef $id $args } - variable argdata_cache + variable rawdef_cache_argdata variable argdefcache_unresolved @@ -1155,8 +1173,8 @@ tcl::namespace::eval punk::args { if {!$is_dynamic} { #todo - don't use cached version if 'colour off' vs 'colour on' different to when last resolved! #(e.g example blocks will still have colour if previously resolved) - if {[tcl::dict::exists $argdata_cache $cache_key]} { - return [tcl::dict::get $argdata_cache $cache_key] + if {[tcl::dict::exists $rawdef_cache_argdata $cache_key]} { + return [tcl::dict::get $rawdef_cache_argdata $cache_key] } set normargs [list] foreach a $textargs { @@ -1235,10 +1253,10 @@ tcl::namespace::eval punk::args { tcl::dict::set argdefcache_unresolved $cache_key $pt_params } } - #argdata_cache should be limited in some fashion or will be a big memory leak??? - if {[tcl::dict::exists $argdata_cache [list $optionspecs]]} { + #rawdef_cache_argdata should be limited in some fashion or will be a big memory leak??? + if {[tcl::dict::exists $rawdef_cache_argdata [list $optionspecs]]} { #resolved cache version exists - return [tcl::dict::get $argdata_cache [list $optionspecs]] + return [tcl::dict::get $rawdef_cache_argdata [list $optionspecs]] } } @@ -2669,10 +2687,12 @@ tcl::namespace::eval punk::args { form_info $form_info\ ] - tcl::dict::set argdata_cache $cache_key $argdata_dict + + #REVIEW + tcl::dict::set rawdef_cache_argdata $cache_key $argdata_dict if {$is_dynamic} { #also cache resolved version - tcl::dict::set argdata_cache [list $optionspecs] $argdata_dict + tcl::dict::set rawdef_cache_argdata [list $optionspecs] $argdata_dict } #tcl::dict::set id_cache_rawdef $DEF_definition_id $args @@ -3094,10 +3114,10 @@ tcl::namespace::eval punk::args { } proc is_dynamic {id} { variable id_cache_rawdef - variable rawdef_cache + variable rawdef_cache_about set deflist [raw_def $id] - if {[dict exists $rawdef_cache $deflist -dynamic]} { - return [dict get $rawdef_cache $deflist -dynamic] + if {[dict exists $rawdef_cache_about $deflist -dynamic]} { + return [dict get $rawdef_cache_about $deflist -dynamic] } return [rawdef_is_dynamic $deflist] #@dynamic only has meaning as 1st element of a def in the deflist @@ -4008,7 +4028,16 @@ tcl::namespace::eval punk::args { } if {$synopsis ne ""} { if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Synopsis: [punk::ansi::ansiwrap brightwhite $synopsis]] + set form_names [dict get $spec_dict form_names] + set synhelp "Synopsis:" + if {[llength $form_names] > 1} { + set fn 0 + foreach fname $form_names { + append synhelp \n " i -form $fn \U2026" + incr fn + } + } + $t configure_header $h -colspans $arg_colspans -values [list $synhelp [punk::ansi::ansiwrap brightwhite $synopsis]] } else { #todo lappend errlines "Synopsis:\n$synopsis" diff --git a/src/modules/punk/args/moduledoc/tclcore-999999.0a1.0.tm b/src/modules/punk/args/moduledoc/tclcore-999999.0a1.0.tm index a32fc215..328804ca 100644 --- a/src/modules/punk/args/moduledoc/tclcore-999999.0a1.0.tm +++ b/src/modules/punk/args/moduledoc/tclcore-999999.0a1.0.tm @@ -390,13 +390,19 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { its cached information. For example, to run the umask shell builtin on Linux, you would do: - exec {*}[auto_execok umask] + ${[example { + exec {*}[${$B}auto_execok${$N} umask] + }]} To run the DIR shell builtin on Windows, you would do: - exec {*}[auto_execok dir] + ${[example { + exec {*}[${$B}auto_execok${$N} dir] + }]} To discover if there is a frobnicate binary on the user's PATH, you would do: - set mayFrob [expr {[llength [auto_execok frobnicate]] > 0}] + ${[example { + set mayFrob [expr {[llength [${$B}auto_execok${$N} frobnicate]] > 0}] + }]} " @values -min 2 -max 2 cmd -type string @@ -939,7 +945,84 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { ${$DYN_INFO_SUBCOMMANDS} @values -unnamed true - } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]" ] + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl info]"\ + { + @examples -help { + This command prints out a procedure suitable for saving in a Tcl script: + ${[example { + proc printProc {procName} { + set result [list proc $procName] + set formals {} + foreach var [${$B}info${$N} args $procName] { + if {[${$B}info${$N} default $procName $var def]} { + lappend formals [list $var $def] + } else { + # Still need the list-quoting because variable + # names may properly contain spaces. + lappend formals [list $var] + } + } + puts [lappend result $formals [${$B}info${$N} body $procName]] + } + }]} + + ${$T}EXAMPLES WITH OBJECTS${$NT} + + Every object necessarily knows what its class is; this information is trivially extractable through introspection: + ${[example { + oo::class create c + c create o + puts [${$B}info${$N} object class o] + → prints "::c" + puts [${$B}info${$N} object class c] + → prints "::oo::class" + }]} + The introspection capabilities can be used to discover what class implements a method and get how it is defined. + This procedure illustrates how: + ${[example { + proc getDef {obj method} { + foreach inf [${$B}info${$N} object call $obj $method] { + lassign $inf calltype name locus methodtype + + # Assume no forwards or filters, and hence no $calltype + # or $methodtype checks... + + if {$locus eq "object"} { + return [${$B}info${$N} object definition $obj $name] + } else { + return [${$B}info${$N} class definition $locus $name] + } + } + error "no definition for $method" + } + }]} + This is an alternate way of looking up the definition; it is implemented by manually scanning the list of methods + up the inheritance tree. This code assumes that only single inheritance is in use, and that there is no complex + use of mixed-in classes (in such cases, using ${$B}info${$N} object call${$N} as above is the simplest way of doing this by far): + ${[example { + proc getDef {obj method} { + if {$method in [${$B}info${$N} object methods $obj]} { + # Assume no forwards + return [${$B}info${$N} object definition $obj $method] + } + + set cls [${$B}info${$N} object class $obj] + + while {$method ni [${$B}info${$N} class methods $cls]} { + # Assume the simple case + set cls [lindex [${$B}info${$N} class superclass $cls] 0] + if {$cls eq ""} { + error "no definition for $method" + } + } + + # Assume no forwards + return [${$B}info${$N} class definition $cls $method] + } + }]} + } + }] + } @@ -1341,24 +1424,46 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { }]} } } - } + } - lappend PUNKARGS [list { - @id -id ::time - @cmd -name "Built-in: time" -help\ - "Calls the Tcl interpreter count times to evaluate script - (or once if count is not specified). It will then return - a string of the form - 503.2 microseconds per iteration - which indicates the average amount of time required per - iteration, in microseconds. Time is measured in elapsed - time, not CPU time. - (see also: timerate)" - @values -min 1 -max 2 - script -type script - count -type integer -default 1 -optional 1 - } "@doc -name Manpage: -url [manpage_tcl time]" ] + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::time + @cmd -name "Built-in: time"\ + -summary\ + "Time a script."\ + -help\ + "Calls the Tcl interpreter count times to evaluate script + (or once if count is not specified). It will then return + a string of the form + ${[example { + 503.2 microseconds per iteration + }]} + which indicates the average amount of time required per + iteration, in microseconds. Time is measured in elapsed + time, not CPU time. + (see also: timerate)" + @values -min 1 -max 2 + script -type script + count -type integer -default 1 -optional 1 + } "@doc -name Manpage: -url [manpage_tcl time]"\ + { + @examples -help { + Estimate how long it takes for a simple Tcl ${$B}for${$N} loop to count to a thousand: + ${[example { + ${$B}time${$N} { + for {set i 0} {$i<1000} {incr i} { + # empty body + } + } + }]} + } + } { + @seealso -commands {clock} + } + ] + } namespace eval argdoc { lappend PUNKARGS [list { @@ -1868,7 +1973,45 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { offset places the access position before the end of file, and a positive offset places the access position after the end of file." } - } "@doc -name Manpage: -url [manpage_tcl chan]" ] + } "@doc -name Manpage: -url [manpage_tcl chan]"\ + { + @examples -help { + ${$T}FILE SEEK EXAMPLES${$NT} + + Read a file twice: + ${[example { + set f [open file.txt] + set data1 [chan read $f] + ${$B}chan seek${$N} $f 0 + set data2 [chan read $f] + chan close $f + # $data1 eq $data2 if the file wasn't updated + }]} + Read the last 10 bytes from a file: + ${[example { + set f [open file.data] + # This is guaranteed to work with binary data but + # may fail with other encodings... + chan configure $f -translation binary + ${$B}chan seek${$N} $f -10 end + set data [chan read $f 10] + chan close $f + }]} + Read a line from a file channel only if it starts with ${$B}foobar${$N}: + ${[example { + # Save the offset in case we need to undo the read... + set offset [${$B}tell${$N} $chan] + if {[read $chan 6] eq "foobar"} { + gets $chan line + } else { + set line {} + # Undo the read... + seek $chan $offset + } + }]} + } + }\ + ] lappend PUNKARGS [list { @id -id ::tcl::chan::tell @@ -1908,7 +2051,7 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { #todo ::chan base ensemble definition - #@examples (include: see 'eg chan read') + #@examples (include: see 'eg chan read' eg 'chan seek' eg 'chan copy') # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- #dict @@ -3742,7 +3885,37 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { @values -min 0 -max 1 id -optional 1 - } "@doc -name Manpage: -url [manpage_tcl after]" ] + } "@doc -name Manpage: -url [manpage_tcl after]"\ + { + @examples -help { + This defines a command to make Tcl do nothing at all for N seconds: + ${[example { + proc sleep {N} { + ${$B}after${$N} [expr {int($N * 1000)}] + } + }]} + This arranges for the command wake_up to be run in eight hours (providing the event loop is active at that time): + ${[example { + ${$B}after${$N} [expr {1000 * 60 * 60 * 8}] wake_up + }]} + The following command can be used to do long-running calculations (as represented here by ::my_calc::one_step, + which is assumed to return a boolean indicating whether another step should be performed) in a step-by-step + fashion, though the calculation itself needs to be arranged so it can work step-wise. This technique is extra + careful to ensure that the event loop is not starved by the rescheduling of processing steps (arranging for the + next step to be done using an already-triggered timer event only when the event queue has been drained) and is + useful when you want to ensure that a Tk GUI remains responsive during a slow task. + ${[example { + proc doOneStep {} { + if {[::my_calc::one_step]} { + ${$B}after idle${$N} [list ${$B}after${$N} 0 doOneStep] + } + } + doOneStep + }]} + } + } { + @seealso -commands {concat interp update vwait} + }] namespace eval argdoc { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -4151,6 +4324,38 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { } }] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::cd + @cmd -name "Built-in: cd"\ + -summary\ + "Change working directory"\ + -help\ + "Change the current working directory to dirName, or to the home directory (as specified in + the HOME environment variable) if dirName is not given. + Returns an empty string. + Note that the current working directory is a per-process resource; the ${$B}cd${$N} command changes + the working directory for all interpreters and all threads." + @values -min 0 -max 1 + dirName -type directory -optional 1 -help\ + "target directory. + If not supplied - will cd to home directory" + } "@doc -name Manpage: -url [manpage_tcl cd]"\ + { + @examples -help { + Change to the home directory of the user ${$B}fred${$N}: + ${[example { + cd [file home fred] + }]} + Change to the directory ${$B}lib${$N} that is a sibling directory of the current one: + ${[example { + cd ../lib + }]} + } + } { + @seealso -commands {filename glob pwd} + }] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- #TODO - add CLOCK_ARITHMETIC documentation #TODO - TIME ZONES documentation? @@ -4636,7 +4841,7 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { tags. If a field is given, this command extracts that field as described below. Any other field value not mentioned below will always return \"0\"." @leaders -min 0 -max 1 - field -type string -optional 1 -choicecolumns 3\ + field -type string -optional 1 -choiceprefix 0 -choicecolumns 3\ -choices { clang commit compiledebug compiler compilestats cplusplus debug gcc icc ilp32 memdebug msvc nmake no-deprecate no-thread no-optimize objective-c objective-cplusplus patchlevel profile @@ -4951,6 +5156,60 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { } }] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::fpclassify + @cmd -name "Built-in: fpclassify"\ + -summary\ + "Floating point number classification of Tcl values."\ + -help\ + "The ${$B}fpclassify${$N} command takes a floating point number, ${$I}value${$NI}, and returns + one of the following strings that describe it: + + ${$B}zero${$N} + ${$I}value${$NI} is a floating point zero. + ${$B}subnormal${$N} + ${$I}value${$NI} is the result of a gradual underflow. + ${$B}normal${$N} + ${$I}value${$NI} is an ordinary floating-point number (not zero, subnormal, infinite, nor NaN). + ${$B}infinite${$N} + ${$I}value${$NI} is a floating-point infinity. + ${$B}nan${$N} + ${$I}value${$NI} is Not-a-Number. + + The ${$B}fpclassify${$N} command throws an error if ${$I}value${$NI} is not a floating-point value and cannot be converted to one." + @values -min 1 -max 1 + value -type any + } "@doc -name Manpage: -url [manpage_tcl fpclassify]"\ + { + @examples -help { + This shows how to check whether the result of a computation is numerically safe or not. + (Note however that it does not guard against numerical errors; just against + representational problems.) + ${[example { + set value [command-that-computes-a-value] + switch [${$B}fpclassify${$N} $value] { + normal - zero { + puts "Result is $value" + } + infinite { + puts "Result is infinite" + } + subnormal { + puts "Result is $value - WARNING! precision lost" + } + nan { + puts "Computation completely failed" + } + } + }]} + } + }\ + { + @seealso -commands {expr} -topics {mathfunc} + }] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + lappend PUNKARGS [list { @id -id ::gets @cmd -name "Built-in: gets"\ @@ -4970,9 +5229,20 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { -summary\ "Return names of files that match patterns."\ -help\ - "This command performs file name “globbing” in a fashion similar to the csh shell or bash shell. + {This command performs file name “globbing” in a fashion similar to the csh shell or bash shell. It returns a list of the files whose names match any of the pattern arguments. No particular - order is guaranteed in the list, so if a sorted list is required the caller should use lsort." + order is guaranteed in the list, so if a sorted list is required the caller should use lsort. + + ${$T}WINDOWS PORTABILITY ISSUES${$NT} + For Windows UNC names, the servername and sharename components of the path may not contain + ?, *, or [] constructs. + + Since the backslash character has a special meaning to the glob command, glob patterns containing + Windows style path separators need special care. The pattern “C:\\foo\\*” is interpreted as + “C:\foo\*” where “\f” will match the single character “f” and “\*” will match the single character + “*” and will not be interpreted as a wildcard character. One solution to this problem is to use + the Unix style forward slash as a path separator. Windows style paths can be converted to Unix + style paths with the command “${$B}file join $path${$N}” or “${$B}file normalize $path${$N}”.} @opts -directory -type directory -help\ "Search for files which match the given patterns starting in the given ${$I}directory${$NI}. @@ -5053,9 +5323,30 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { (use the lsort command if you want the list sorted). Second, glob only returns the names of files that actually exist; in csh no check for existence is made unless a pattern contains a ?, *, or [] construct." - } "@doc -name Manpage: -url [manpage_tcl glob]" ] + } "@doc -name Manpage: -url [manpage_tcl glob]"\ + { + @examples -help { + Find all the Tcl files in the current directory: + ${[example { + ${$B}glob${$N} *.tcl + }]} + Find all the Tcl files in the user's home directory, irrespective of what the current directory is: + ${[example { + ${$B}glob${$N} -directory [file home] *.tcl + }]} + Find all subdirectories of the current directory: + ${[example { + ${$B}glob${$N} -type d * + }]} + Find all files whose name contains an “a”, a “b” or the sequence “cde”: + ${[example { + ${$B}glob${$N} -type f *{a,b,cde}* + }]} + } + }] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - lappend PUNKARGS [list { + lappend PUNKARGS [list\ + { @id -id ::global @cmd -name "Built-in: global"\ -summary\ @@ -5071,7 +5362,31 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { looks like an array element, such as ${$B}a(b)${$N}." @values -min 0 -max -1 varName -multiple 1 -optional 1 - } "@doc -name Manpage: -url [manpage_tcl global]" ] + } "@doc -name Manpage: -url [manpage_tcl global]"\ + { + @examples -help { + This procedure sets the namespace variable ::a::x + ${[example { + proc reset {} { + ${$B}global${$N} a::x + set x 0 + } + }]} + This procedure accumulates the strings passed to it in a global buffer, separated by newlines. + It is useful for situations when you want to build a message piece-by-piece (as if with ${$B}puts${$N}) + but send that full message in a single piece (e.g. over a connection opened with ${$B}socket${$N} or as + part of a counted HTTP response). + ${[example { + proc accum {string} { + ${$B}global${$N} accumulator + append accumulator $string \n + } + }]} + } + }\ + { + @seealso -commands {namespace upvar variable} + }] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- } @@ -5216,7 +5531,7 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { the same as the current names of the commands)." @values -min 0 -max 1 path -type string -optional 1 - } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl aliases]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl interp]" punk::args::define { @id -id "::interp bgerror" @@ -5231,7 +5546,102 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { @values -min 1 -max 2 path -type string -optional 0 cmdPrefix -type list -optional 1 - } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl aliases]" + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl interp]" + + punk::args::define { + @id -id "::interp cancel" + @cmd -name "Built-in: ::interp cancel"\ + -summary\ + "Cancel interp script"\ + -help\ + "Cancels the script being evaluated in the interpreter identified by path. Without the ${$B}-unwind${$N} switch + the evaluation stack for the interpreter is unwound until an enclosing catch command is found or there + are no further invocations of the interpreter left on the call stack. With the ${$B}-unwind${$N} switch the + evaluation stack for the interpreter is unwound without regard to any intervening catch command until + there are no further invocations of the interpreter left on the call stack. The -- switch can be used + to mark the end of switches; it may be needed if path is an unusual value such as ${$B}-safe${$N}. If result is + present, it will be used as the error message string; otherwise, a default error message string will + be used." + @opts + -unwind -type none + -- -type none + @values -min 0 -max 2 + path -type string -optional 1 + result -type string -optional 1 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl interp]" + + punk::args::define { + @id -id "::interp children" + @cmd -name "Built-in: ::interp children"\ + -summary\ + "List child interpreters."\ + -help\ + "Returns a Tcl list of the names of all the child interpreters associated with the interpreter identified by ${$I}path${$NI}. + If ${$I}path${$NI} is omitted, the invoking interpreter is used." + @values -min 0 -max 1 + path -type string -optional 1 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl interp]" + + punk::args::define { + @id -id "::interp create" + @cmd -name "Built-in: ::interp create"\ + -summary\ + "Create a child interpreter."\ + -help\ + "Creates a child interpreter identified by ${$I}path${$NI} and a new command, called a ${$I}child${$NI} command. + The name of the child command is the last component of path. The new child interpreter and the child + command are created in the interpreter identified by the path obtained by removing the last component + from path. For example, if path is ${$B}a b c${$N} then a new child interpreter and child command named c are + created in the interpreter identified by the path ${$B}a b${$N}. The child command may be used to manipulate + the new interpreter as described below. If ${$I}path${$NI} is omitted, Tcl creates a unique name of the form + ${$B}interp${$N}${$I}x${$NI}, where x is an integer, and uses it for the interpreter and the child command. + If the ${$B}-safe${$N} switch is specified (or if the parent interpreter is a safe interpreter), the new child + interpreter will be created as a safe interpreter with limited functionality; otherwise the child will + include the full set of Tcl built-in commands and variables. The -- switch can be used to mark the + end of switches; it may be needed if ${$I}path${$NI} is an unusual value such as ${$B}-safe${$N}. The result of the + command is the name of the new interpreter. The name of a child interpreter must be unique among all + the children for its parent; an error occurs if a child interpreter by the given name already exists + in this parent. The initial recursion limit of the child interpreter is set to the current recursion + limit of its parent interpreter." + @opts + -safe -type none + -- -type none + @values -min 0 -max 1 + path -type string -optional 1 + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl interp]" + + + punk::args::define { + @id -id "::interp limit" + @cmd -name "Built-in: ::interp limit"\ + -summary\ + "Resource limit configuration."\ + -help\ + "" + @form -form {configure query} + @leaders + path -type string + limitType -type {literalprefix(commands)|literalprefix(time)} -choices {commands time} + + @form -form configure + @values -min 0 -max -1 + #TODO - choice-parameters + #?? -choiceparameters {literalprefix type} + optionpair\ + -type {string any}\ + -typesynopsis {${$I}-option value${$NI}}\ + -optional 0\ + -multiple 1\ + -choicerestricted 0\ + -choices {{-command string} {-granularity int} {-milliseconds int} {-seconds int} {-value any}}\ + -help "(todo: adjust args definition to validate optionpairs properly)" + + @form -form query + @values -min 0 -max 1 + option -type string -typesynopsis {${$I}-option${$NI}} -optional 1 -choices {-command -granularity -seconds -milliseconds} + + } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl interp]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # ::interp @@ -5285,7 +5695,8 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { {${$INTERP_CHOICELABELS}}\ -choiceinfo {${$INTERP_CHOICEINFO}} @values -unnamed true - } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl interp]"\ + }\ + "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl interp]"\ { @examples -help { Creating and using an alias for a command in the current interpreter: @@ -7182,7 +7593,7 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { -summary\ "Perform substitutions based on regular expression pattern matching."\ -help\ - "This command matches the regular expression ${$I}exp${$NI} against ${$I}string${$NI}, and either copies string to the + {This command matches the regular expression ${$I}exp${$NI} against ${$I}string${$NI}, and either copies string to the variable whose name is given by ${$I}varName${$NI} or returns ${$I}string${$NI} if ${$I}varName${$NI} is not present. (Regular expression matching is described in the re_syntax reference page.) If there is a match, then while copying ${$I}string${$NI} to ${$I}varName${$NI} (or to the result of this command if ${$I}varName${$NI} is not present) the portion @@ -7194,7 +7605,7 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { backslashes in ${$I}subSpec${$NI} tends to interact badly with the Tcl parser's use of backslashes, so it is generally safest to enclose ${$I}subSpec${$NI} in braces if it includes backslashes. - If the initial arguments to ${$B}regsub${$N} start with - then they are treated as switches." + If the initial arguments to ${$B}regsub${$N} start with - then they are treated as switches.} @leaders -min 0 -max 0 @opts -all -type none -help\ @@ -7222,6 +7633,7 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { "Enables use of the expanded regular expression syntax where whitespace and comments are ignored. This is the same as specifying the (?x) embedded option (see the re_syntax manual page). " + # the @# not needed if we were to brace this next -help value instead of double quoting it. -line -type none -help\ "Enables newline-sensitive matching. By default, newline is a completely ordinary character with no special meaning. With this flag, “[^” bracket expressions and “.” never match newline, “^” @@ -7295,7 +7707,6 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { ${[example { # This RE is just a character class for everything "bad" set RE {[][{};#\\\$\s\u0080-\uffff]} - # This encodes what the RE described above matches proc encodeChar {ch} { # newline is handled specially since backslash-newline is a @@ -7620,6 +8031,204 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { } } + punk::args::define { + @id -id ::scan + @cmd -name "Built-in: scan"\ + -summary\ + "Parse string using conversion specifiers in the style of sscanf."\ + -help {\ + ${$T}INTRODUCTION${$NT} + This command parses substrings from an input string in a fashion similar to the ANSI + C ${$B}sscanf${$N} procedure and returns a count of the number of conversions performed, or ${$B}-1${$N} + if the end of the input string is reached before any conversions have been performed. + String gives the input to be parsed and format indicates how to parse it, using ${$B}%${$N} + conversion specifiers as in ${$B}sscanf${$N}. Each varName gives the name of a variable; when a + substring is scanned from string that matches a conversion specifier, the substring + is assigned to the corresponding variable. If no varName variables are specified, + then ${$B}scan${$N} works in an inline manner, returning the data that would otherwise be stored + in the variables as a list. In the inline case, an empty string is returned when the + end of the input string is reached before any conversions have been performed. + + ${$T}DETAILS ON SCANNING${$NT} + Scan operates by scanning string and format together. If the next character in format + is a blank or tab then it matches any number of white space characters in string + (including zero). Otherwise, if it is not a % character then it must match the next + character of string. When a % is encountered in format, it indicates the start of a + conversion specifier. A conversion specifier contains up to four fields after the %: + a XPG3 position specifier (or a * to indicate the converted value is to be discarded + instead of assigned to any variable); a number indicating a maximum substring width; + a size modifier; and a conversion character. All of these fields are optional except + for the conversion character. The fields that are present must appear in the order + given above. + + When scan finds a conversion specifier in format, it first skips any white-space + characters in string (unless the conversion character is [ or c). Then it converts + the next input characters according to the conversion specifier and stores the result + in the variable given by the next argument to scan. + + ${$T}OPTIONAL POSITION SPECIFIER${$NT} + If the % is followed by a decimal number and a $, as in “%2$d”, then the variable to + use is not taken from the next sequential argument. Instead, it is taken from the + argument indicated by the number, where 1 corresponds to the first varName. If there + are any positional specifiers in format then all of the specifiers must be positional. + Every varName on the argument list must correspond to exactly one conversion specifier + or an error is generated, or in the inline case, any position can be specified at most + once and the empty positions will be filled in with empty strings. + + ${$T}OPTIONAL SIZE MODIFIER${$NT} + The size modifier field is used only when scanning a substring into one of Tcl's + integer values. The size modifier field dictates the integer range acceptable to be + stored in a variable, or, for the inline case, in a position in the result list. The + syntactically valid values for the size modifier are h, l, z, t, q, j, ll, and L. The h + size modifier value is equivalent to the absence of a size modifier in the the + conversion specifier. Either one indicates the integer range to be stored is limited to + the 32-bit range. The L size modifier is equivalent to the ll size modifier. Either one + indicates the integer range to be stored is unlimited. The l (or q or j) size modifier + indicates that the integer range to be stored is limited to the same range produced by + the wide() function of the expr command. The z and t modifiers indicate the integer + range to be the same as for either h or l, depending on the value of the pointerSize + element of the tcl_platform array. + + ${$T}MANDATORY CONVERSION CHARACTER${$NT} + The following conversion characters are supported: + ${$B}d${$N} + The input substring must be a decimal integer. It is read in and the integer value + is stored in the variable, truncated as required by the size modifier value. + ${$B}o${$N} + The input substring must be an octal integer. It is read in and the integer value + is stored in the variable, truncated as required by the size modifier value. + ${$B}x${$N} or ${$B}X${$N} + The input substring must be a hexadecimal integer. It is read in and the integer + value is stored in the variable, truncated as required by the size modifier value. + ${$B}b${$N} + The input substring must be a binary integer. It is read in and the integer value + is stored in the variable, truncated as required by the size modifier value. + ${$B}u${$N} + The input substring must be a decimal integer. The integer value is truncated as + required by the size modifier value, and the corresponding unsigned value for that + truncated range is computed and stored in the variable as a decimal string. + ${$B}i${$N} + The input substring must be an integer. The base (i.e. decimal, octal, or + hexadecimal) is determined by the C convention (leading 0 for octal; prefix 0x for + hexadecimal). The integer value is stored in the variable, truncated as required + by the size modifier value. + ${$B}c${$N} + A single character is read in and its Unicode value is stored in the variable as + an integer value. Initial white space is not skipped in this case, so the input + substring may be a white-space character. + ${$B}s${$N} + The input substring consists of all the characters up to the next white-space + character; the characters are copied to the variable. + ${$B}e${$N} or ${$B}f${$N} or ${$B}g${$N} or ${$B}E${$N} or ${$B}G${$N} + The input substring must be a floating-point number consisting of an optional + sign, a string of decimal digits possibly containing a decimal point, and an + optional exponent consisting of an e or E followed by an optional sign and a + string of decimal digits. It is read in and stored in the variable as a + floating-point value. + ${$B}[${$N}chars${$B}]${$N} + The input substring consists of one or more characters in chars. The matching + string is stored in the variable. If the first character between the brackets + is a ] then it is treated as part of chars rather than the closing bracket for + the set. If chars contains a sequence of the form a-b then any character between a + and b (inclusive) will match. If the first or last character between the brackets + is a -, then it is treated as part of chars rather than indicating a range. + ${$B}[${$N}^chars${$B}]${$N} + The input substring consists of one or more characters not in chars. The matching + string is stored in the variable. If the character immediately following the ^ is a + ] then it is treated as part of the set rather than the closing bracket for the set. + If chars contains a sequence of the form a-b then any character between a and b + (inclusive) will be excluded from the set. If the first or last character between + the brackets is a -, then it is treated as part of chars rather than indicating a + range value. + ${$B}n${$N} + No input is consumed from the input string. Instead, the total number of characters + scanned from the input string so far is stored in the variable. + + The number of characters read from the input for a conversion is the largest number that + makes sense for that particular conversion (e.g. as many decimal digits as possible for + ${$B}%d${$N}, as many octal digits as possible for ${$B}%o${$N}, and so on). The input substring for a given + conversion terminates either when a white-space character is encountered or when the + maximum substring width has been reached, whichever comes first. If a ${$B}*${$N} is present in + the conversion specifier then no variable is assigned and the next scan argument is not + consumed. + + ${$T}DIFFERENCES FROM ANSI SSCANF${$NT} + The behavior of the ${$B}scan${$N} command is the same as the behavior of the ANSI C sscanf + procedure except for the following differences: + 1. ${$B}%p${$N} conversion specifier is not supported. + 2. For ${$B}%c${$N} conversions a single character value is converted to a decimal string, + which is then assigned to the corresponding varName; no substring width may be + specified for this conversion. + 3. The ${$B}h${$N} modifier is always ignored and the ${$B}l${$N} and ${$B}L${$N} modifiers are ignored when + converting real values (i.e. type double is used for the internal representation). + The ${$B}ll${$N} modifier has no ${$B}sscanf${$N} counterpart. + 4. If the end of the input string is reached before any conversions have been + performed and no variables are given, an empty string is returned. + } + @values -min 1 -max 2 + string -type string + format -type string + varName -type string -optional 1 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl scan]"\ + { + @examples -help { + Convert a UNICODE character to its numeric value: + ${[example { + set char "x" + set value [${$B}scan${$N} $char %c] + }]} + Parse a simple color specification of the form #RRGGBB using hexadecimal conversions with substring sizes: + ${[example { + set string "#08D03F" + ${$B}scan${$N} $string "#%2x%2x%2x" r g b + }]} + Parse a HH:MM time string: + ${[example { + set string "08:08" + if {[${$B}scan${$N} $string "%d:%d" hours minutes] != 2} { + error "not a valid time string" + } + # We have to understand numeric ranges ourselves... + if {$minutes < 0 || $minutes > 59} { + error "invalid number of minutes" + } + }]} + Break a string up into sequences of non-whitespace characters (note the use of the %n conversion so that we + get skipping over leading whitespace correct): + ${[example { + set string " a string {with braced words} + leading space " + set words {} + while {[${$B}scan${$N} $string %s%n word length] == 2} { + lappend words $word + set string [string range $string $length end] + } + }]} + Parse a simple coordinate string, checking that it is complete by looking for the terminating character + explicitly: + ${[example { + set string "(5.2,-4e-2)" + # Note that the spaces before the literal parts of + # the scan pattern are significant, and that ")" is + # the Unicode character \u0029 + if { + [${$B}scan${$N} $string " (%f ,%f %c" x y last] != 3 + || $last != 0x0029 + } then { + error "invalid coordinate string" + } + puts "X=$x, Y=$y" + }]} + An interactive session demonstrating the truncation of integer values determined by size modifiers: + ${[example { + % scan 20000000000000000000 %d + 2147483647 + % scan 20000000000000000000 %ld + 9223372036854775807 + % scan 20000000000000000000 %lld + 20000000000000000000 + }]} + } + } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::set @@ -8621,7 +9230,58 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { -novariables -type none @values -min 1 -max -1 string -type string - } "@doc -name Manpage: -url [manpage_tcl subst]" + } "@doc -name Manpage: -url [manpage_tcl subst]"\ + { + @examples -help { + When it performs its substitutions, subst does not give any special treatment to double + quotes or curly braces (except within command substitutions) so the script + ${[example { + set a 44 + subst {xyz {$a}} + }]} + returns “xyz {44}”, not “xyz {$a}” and the script + ${[example -syntax tcl { + set a "p\} q \{r" + subst {xyz {$a}} + }]} + returns “xyz {p} q {r}”, not “xyz {p\} q \{r}”. + When command substitution is performed, it includes any variable substitution necessary + to evaluate the script. + ${[example { + set a 44 + subst -novariables {$a [format $a]} + }]} + returns “$a 44”, not “$a $a”. Similarly, when variable substitution is performed, it + includes any command substitution necessary to retrieve the value of the variable. + ${[example { + proc b {} {return c} + array set a {c c [b] tricky} + subst -nocommands {[b] $a([b])} + }]} + returns “[b] c”, not “[b] tricky”. + The continue and break exceptions allow command substitutions to prevent substitution of + the rest of the command substitution and the rest of string respectively, giving script + authors more options when processing text using subst. For example, the script + ${[example { + subst {abc,[break],def} + }]} + returns “abc,”, not “abc,,def” and the script + ${[example { + subst {abc,[continue;expr {1+2}],def} + }]} + returns “abc,,def”, not “abc,3,def”. + + Other exceptional return codes substitute the returned value + ${[example { + subst {abc,[return foo;expr {1+2}],def} + }]} + returns “abc,foo,def”, not “abc,3,def” and + ${[example { + subst {abc,[return -code 10 foo;expr {1+2}],def} + }]} + also returns “abc,foo,def”, not “abc,3,def”. + } + } } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -8845,87 +9505,124 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { } "@doc -name Manpage: -url [manpage_tcl throw]" - } - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - punk::args::define { - @id -id ::trace - @cmd -name "Built-in: trace"\ - -summary\ - "Monitor variable accesses, command usages and command executions."\ - -help\ - "This command causes Tcl commands to be executed whenever certain - operations are invoked. " + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::trace + @cmd -name "Built-in: trace"\ + -summary\ + "Monitor variable accesses, command usages and command executions."\ + -help\ + "This command causes Tcl commands to be executed whenever certain + operations are invoked. " - #@form -synopsis "trace option ?arg arg...?" - @leaders -min 1 -max 1 - option -choicegroups { - "" {add remove info} - obsolete {variable vdelete vinfo} - }\ - -choiceinfo { - add {{doctype punkargs} {subhelp ::trace add}} - remove {{doctype punkargs} {subhelp ::trace remove}} - } - @values -unnamed true + #@form -synopsis "trace option ?arg arg...?" + @leaders -min 1 -max 1 + option -choicegroups { + "" {add remove info} + obsolete {variable vdelete vinfo} + }\ + -choiceinfo { + add {{doctype punkargs} {subhelp ::trace add}} + remove {{doctype punkargs} {subhelp ::trace remove}} + } + @values -unnamed true - } "@doc -name Manpage: -url [manpage_tcl trace]" + } "@doc -name Manpage: -url [manpage_tcl trace]"\ + { + @examples -help { + Print a message whenever either of the global variables ${$B}foo${$N} and ${$B}bar${$N} are updated, even if they have + a different local name at the time (which can be done with the upvar command): + ${[example { + proc tracer {varname args} { + upvar #0 $varname var + puts "$varname was updated to be \"$var\"" + } + ${$B}trace add${$N} variable foo write "tracer foo" + ${$B}trace add${$N} variable bar write "tracer bar" + }]} + Ensure that the global variable ${$B}foobar${$N} always contains the product of the global variables ${$B}foo${$N} and ${$B}bar${$N}: + ${[example { + proc doMult args { + global foo bar foobar + set foobar [expr {$foo * $bar}] + } + ${$B}trace add${$N} variable foo write doMult + ${$B}trace add${$N} variable bar write doMult + }]} + Print a trace of what commands are executed during the processing of a Tcl procedure: + ${[example { + proc x {} { y } + proc y {} { z } + proc z {} { puts hello } + proc report args {puts [info level 0]} + ${$B}trace add${$N} execution x enterstep report + x + → report y enterstep + report z enterstep + report {puts hello} enterstep + hello + }]} + } + } { + @seealso -commands {set unset} + } - punk::args::define { - @id -id "::trace add" - @cmd -name "Built-in: trace add"\ - -summary\ - "Add a command, execution or variable trace."\ - -help\ - "Add a command, execution or variable trace." - @form -synopsis "trace add type name ops ?args?" - @leaders - type -choicegroups { - "" {command execution variable} - }\ - -choiceinfo { - command {{doctype punkargs} {subhelp ::trace add command}} - execution {{doctype punkargs} {subhelp ::trace add execution}} - variable {{doctype punkargs}} - } + punk::args::define { + @id -id "::trace add" + @cmd -name "Built-in: trace add"\ + -summary\ + "Add a command, execution or variable trace."\ + -help\ + "Add a command, execution or variable trace." + @form -synopsis "trace add type name ops ?args?" + @leaders + type -choicegroups { + "" {command execution variable} + }\ + -choiceinfo { + command {{doctype punkargs} {subhelp ::trace add command}} + execution {{doctype punkargs} {subhelp ::trace add execution}} + variable {{doctype punkargs}} + } - } "@doc -name Manpage: -url [manpage_tcl trace]" + } "@doc -name Manpage: -url [manpage_tcl trace]" - punk::args::define { - @id -id "::trace add command" - @cmd -name "Built-in: trace add command"\ - -summary\ - "Add command trace for operation(s): rename delete"\ - -help\ - "Arrange for commandPrefix to be executed (with additional arguments) - whenever command name is modified in one of the ways given by the list - ops. Name will be resolved using the usual namespace resolution rules - used by commands. If the command does not exist, an error will be thrown." - name -type string -help\ - "Name of command" - ops -type list -choices {rename delete} -choiceprefix 0 -choicemultiple {1 2}\ - -choicelabels { + punk::args::define { + @id -id "::trace add command" + @cmd -name "Built-in: trace add command"\ + -summary\ + "Add command trace for operation(s): rename delete"\ + -help\ + "Arrange for commandPrefix to be executed (with additional arguments) + whenever command name is modified in one of the ways given by the list + ops. Name will be resolved using the usual namespace resolution rules + used by commands. If the command does not exist, an error will be thrown." + name -type string -help\ + "Name of command" + ops -type list -choices {rename delete} -choiceprefix 0 -choicemultiple {1 2}\ + -choicelabels { rename\ - " Invoke commandPrefix whenever the traced command - is renamed. Note that renaming to the empty string - is considered deletion, and will not be traced with - 'rename'" + " Invoke commandPrefix whenever the traced command + is renamed. Note that renaming to the empty string + is considered deletion, and will not be traced with + '${$B}rename${$N}'" delete\ - " Invoke commandPrefix when the traced command is deleted. - Commands can be deleted explicitly using the rename command to - rename the command to an empty string. Commands are also deleted - when the interpreter is deleted, but traces will not be invoked - because there is no interpreter in which to execute them." - }\ - -help\ - "Indicates which operations are of interest." - commandPrefix -type string -help\ - "When the trace triggers, depending on the operations being traced, a - number of arguments are appended to commandPrefix so that the actual - command is as follows: - -------------------------------- - commandPrefix oldName newName op - -------------------------------- + " Invoke commandPrefix when the traced command is deleted. + Commands can be deleted explicitly using the rename command to + rename the command to an empty string. Commands are also deleted + when the interpreter is deleted, but traces will not be invoked + because there is no interpreter in which to execute them." + }\ + -help\ + "Indicates which operations are of interest." + commandPrefix -type string -help\ + "When the trace triggers, depending on the operations being traced, a + number of arguments are appended to commandPrefix so that the actual + command is as follows: + ${[example { + commandPrefix oldName newName op + }]} OldName and newName give the traced command's current (old) name, and the name to which it is being renamed (the empty string if this is a \"delete\" operation). Op indicates what operation is being @@ -8938,300 +9635,304 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { cause further trace evaluations to occur. Both oldName and newName are fully qualified with any namespace(s) in which they appear. " - } "@doc -name Manpage: -url [manpage_tcl trace]" + } "@doc -name Manpage: -url [manpage_tcl trace]" + + punk::args::define { + @id -id "::trace add variable" + @cmd -name "Built-in: trace add variable"\ + -summary\ + "Add variable trace for operation(s): array read write unset."\ + -help\ + "Arrange for commandPrefix to be executed whenever variable name is accessed + in one of the ways given by the list ops. Name may refer to a normal variable, + an element of an array, or to an array as a whole (i.e. name may be just the + name of an array, with no parenthesized index). If name refers to a whole + array, then commandPrefix is invoked whenever any element of the array is + manipulated. If the variable does not exist, it will be created but will not + be given a value, so it will be visible to namespace which queries, but not to + info exists queries." + name -type string -help\ + "Name of variable" + # --------------------------------------------------------------- + ops -type list -choices {array read write unset} -choiceprefix 0\ + -choicemultiple {1 4}\ + -choicecolumns 1\ + -choicelabels { + array\ + " Invoke commandPrefix whenever the variable is accessed or + modified via the array command, provided that name is not a + scalar variable at the time that the array command is invoked. + If name is a scalar variable, the access via the array command + will not trigger the trace." + read\ + " Invoke commandPrefix whenever the variable isread." + write\ + " Invoke commandPrefix whenever the variable is written." + unset\ + " Invoke commandPrefix whenever the variable is unset. Variables + can be unset explicitly with the unset command, or implicitly + when procedures return (all of their local variables are unset). + Variables are also unset when interpreters are deleted, but + traces will not be invoked because there is no interpreter in + which to execute them." + }\ + -help\ + "Indicates which operations are of interest." + commandPrefix -type string -help\ + "When the trace triggers, three arguments are appended to commandPrefix + so that the actual command is as follows: + ${[example { + commandPrefix name1 name2 op + }]} + Name1 gives the name for the variable being accessed. This is not + necessarily the same as the name used in the trace add variable command: + the upvar command allows a procedure to reference a variable under a + different name. If the trace was originally set on an array or array + element, name2 provides which index into the array was affected. This + information is present even when name1 refers to a scalar, which may + happen if the upvar command was used to create a reference to a single + array element. If an entire array is being deleted and the trace was + registered on the overall array, rather than a single element, then + name1 gives the array name and name2 is an empty string. Op indicates + what operation is being performed on the variable, and is one of read, + write, or unset as defined above. + + CommandPrefix executes in the same context as the code that invoked the + traced operation: if the variable was accessed as part of a Tcl procedure, + then commandPrefix will have access to the same local variables as code in + the procedure. This context may be different than the context in which the + trace was created. If commandPrefix invokes a procedure (which it normally + does) then the procedure will have to use upvar or uplevel if it wishes to + access the traced variable. Note also that name1 may not necessarily be + the same as the name used to set the trace on the variable; differences + can occur if the access is made through a variable defined with the upvar + command. + + For read and write traces, commandPrefix can modify the variable to affect + the result of the traced operation. If commandPrefix modifies the value of + a variable during a read or write trace, then the new value will be + returned as the result of the traced operation. The return value from + commandPrefix is ignored except that if it returns an error of any sort + then the traced operation also returns an error with the same error message + returned by the trace command (this mechanism can be used to implement + read-only variables, for example). For write traces, commandPrefix is + invoked after the variable's value has been changed; it can write a new + value into the variable to override the original value specified in the + write operation. To implement read-only variables, commandPrefix will have + to restore the old value of the variable. + + While commandPrefix is executing during a read or write trace, traces on + the variable are temporarily disabled. This means that reads and writes + invoked by commandPrefix will occur directly, without invoking + commandPrefix (or any other traces) again. However, if commandPrefix + unsets the variable then unset traces will be invoked. + + When an unset trace is invoked, the variable has already been deleted: it + will appear to be undefined with no traces. If an unset occurs because of + a procedure return, then the trace will be invoked in the variable context + of the procedure being returned to: the stack frame of the returning + procedure will no longer exist. Traces are not disabled during unset + traces, so if an unset trace command creates a new trace and accesses the + variable, the trace will be invoked. Any errors in unset traces are ignored. + + If there are multiple traces on a variable they are invoked in order of + creation, most-recent first. If one trace returns an error, then no further + traces are invoked for the variable. If an array element has a trace set, + and there is also a trace set on the array as a whole, the trace on the + overall array is invoked before the one on the element. + + Once created, the trace remains in effect either until the trace is removed + with the trace remove variable command described below, until the variable + is unset, or until the interpreter is deleted. Unsetting an element of array + will remove any traces on that element, but will not remove traces on the + overall array. + + This command returns an empty string." + } "@doc -name Manpage: -url [manpage_tcl trace]" + + + punk::args::define { + @id -id "::trace add execution" + @cmd -name "Built-in: trace add execution"\ + -summary\ + "Add execution trace for operation(s): enter leave enterstep leavestep."\ + -help\ + "Arrange for commandPrefix to be executed (with additional arguments) + whenever command name is executed, with traces occurring at the points + indicated by the list ops. Name will be resolved using the usual namespace + resolution ruls used by commands. If the command does not exist, and error + will be thrown" + name -type string -help\ + "Name of command" + # --------------------------------------------------------------- + ops -type list -choices {enter leave enterstep leavestep} -choiceprefix 0\ + -choicemultiple {1 4}\ + -choicecolumns 2\ + -choicelabels { + enter\ + " Invoke commandPrefix whenever the command name is executed, + just before the actual execution takes place." + leave\ + " Invoke commandPrefix whenever the command name is executed, + just after the actual execution takes place." + enterstep\ + " Invoke commandPrefix for every Tcl command which is executed + from the start of the execution of the procedure name until + that procedure finishes. CommandPrefix is invoked just before + the actual execution of the Tcl command being reported takes + place. For example if we have + \"proc foo {} { puts \"hello\" }\", then an enterstep trace + would be invoked just before \"puts \"hello\"\" is executed. + Setting an enterstep trace on a command name that does not + refer to a procedure will not result in an error and is + simply ignored." + leavestep\ + " Invoke commandPrefix for every Tcl command which is executed + from the start of the execution of the procedure name until + that procedure finishes. CommandPrefix is invoked just after + the actual execution of the Tcl command being reported takes + place. Setting a leavestep trace on a command name that does + not refer to a procedure will not result in an error and is + simply ignored." + }\ + -help\ + "Indicates which operations are of interest." + commandPrefix -type string -help\ + "When the trace triggers, depending on the operation being traced, a + number of arguments are appended to commandPrefix so that the actual + command is as follows: - punk::args::define { - @id -id "::trace add variable" - @cmd -name "Built-in: trace add variable"\ - -summary\ - "Add variable trace for operation(s): array read write unset."\ - -help\ - "Arrange for commandPrefix to be executed whenever variable name is accessed - in one of the ways given by the list ops. Name may refer to a normal variable, - an element of an array, or to an array as a whole (i.e. name may be just the - name of an array, with no parenthesized index). If name refers to a whole - array, then commandPrefix is invoked whenever any element of the array is - manipulated. If the variable does not exist, it will be created but will not - be given a value, so it will be visible to namespace which queries, but not to - info exists queries." - name -type string -help\ - "Name of variable" - # --------------------------------------------------------------- - ops -type list -choices {array read write unset} -choiceprefix 0\ - -choicemultiple {1 4}\ - -choicecolumns 1\ - -choicelabels { - array\ - " Invoke commandPrefix whenever the variable is accessed or - modified via the array command, provided that name is not a - scalar variable at the time that the array command is invoked. - If name is a scalar variable, the access via the array command - will not trigger the trace." - read\ - " Invoke commandPrefix whenever the variable isread." - write\ - " Invoke commandPrefix whenever the variable is written." - unset\ - " Invoke commandPrefix whenever the variable is unset. Variables - can be unset explicitly with the unset command, or implicitly - when procedures return (all of their local variables are unset). - Variables are also unset when interpreters are deleted, but - traces will not be invoked because there is no interpreter in - which to execute them." - }\ - -help\ - "Indicates which operations are of interest." - commandPrefix -type string -help\ - "When the trace triggers, three arguments are appended to commandPrefix - so that the actual command is as follows: - ----------------------------------------- - commandPrefix name1 name2 op - ----------------------------------------- - Name1 gives the name for the variable being accessed. This is not - necessarily the same as the name used in the trace add variable command: - the upvar command allows a procedure to reference a variable under a - different name. If the trace was originally set on an array or array - element, name2 provides which index into the array was affected. This - information is present even when name1 refers to a scalar, which may - happen if the upvar command was used to create a reference to a single - array element. If an entire array is being deleted and the trace was - registered on the overall array, rather than a single element, then - name1 gives the array name and name2 is an empty string. Op indicates - what operation is being performed on the variable, and is one of read, - write, or unset as defined above. - - CommandPrefix executes in the same context as the code that invoked the - traced operation: if the variable was accessed as part of a Tcl procedure, - then commandPrefix will have access to the same local variables as code in - the procedure. This context may be different than the context in which the - trace was created. If commandPrefix invokes a procedure (which it normally - does) then the procedure will have to use upvar or uplevel if it wishes to - access the traced variable. Note also that name1 may not necessarily be - the same as the name used to set the trace on the variable; differences - can occur if the access is made through a variable defined with the upvar - command. - - For read and write traces, commandPrefix can modify the variable to affect - the result of the traced operation. If commandPrefix modifies the value of - a variable during a read or write trace, then the new value will be - returned as the result of the traced operation. The return value from - commandPrefix is ignored except that if it returns an error of any sort - then the traced operation also returns an error with the same error message - returned by the trace command (this mechanism can be used to implement - read-only variables, for example). For write traces, commandPrefix is - invoked after the variable's value has been changed; it can write a new - value into the variable to override the original value specified in the - write operation. To implement read-only variables, commandPrefix will have - to restore the old value of the variable. - - While commandPrefix is executing during a read or write trace, traces on - the variable are temporarily disabled. This means that reads and writes - invoked by commandPrefix will occur directly, without invoking - commandPrefix (or any other traces) again. However, if commandPrefix - unsets the variable then unset traces will be invoked. - - When an unset trace is invoked, the variable has already been deleted: it - will appear to be undefined with no traces. If an unset occurs because of - a procedure return, then the trace will be invoked in the variable context - of the procedure being returned to: the stack frame of the returning - procedure will no longer exist. Traces are not disabled during unset - traces, so if an unset trace command creates a new trace and accesses the - variable, the trace will be invoked. Any errors in unset traces are ignored. - - If there are multiple traces on a variable they are invoked in order of - creation, most-recent first. If one trace returns an error, then no further - traces are invoked for the variable. If an array element has a trace set, - and there is also a trace set on the array as a whole, the trace on the - overall array is invoked before the one on the element. - - Once created, the trace remains in effect either until the trace is removed - with the trace remove variable command described below, until the variable - is unset, or until the interpreter is deleted. Unsetting an element of array - will remove any traces on that element, but will not remove traces on the - overall array. - - This command returns an empty string." - } "@doc -name Manpage: -url [manpage_tcl trace]" - - - punk::args::define { - @id -id "::trace add execution" - @cmd -name "Built-in: trace add execution"\ - -summary\ - "Add execution trace for operation(s): enter leave enterstep leavestep."\ - -help\ - "Arrange for commandPrefix to be executed (with additional arguments) - whenever command name is executed, with traces occurring at the points - indicated by the list ops. Name will be resolved using the usual namespace - resolution ruls used by commands. If the command does not exist, and error - will be thrown" - name -type string -help\ - "Name of command" - # --------------------------------------------------------------- - ops -type list -choices {enter leave enterstep leavestep} -choiceprefix 0\ - -choicemultiple {1 4}\ - -choicecolumns 2\ - -choicelabels { - enter\ - " Invoke commandPrefix whenever the command name is executed, - just before the actual execution takes place." - leave\ - " Invoke commandPrefix whenever the command name is executed, - just after the actual execution takes place." - enterstep\ - " Invoke commandPrefix for every Tcl command which is executed - from the start of the execution of the procedure name until - that procedure finishes. CommandPrefix is invoked just before - the actual execution of the Tcl command being reported takes - place. For example if we have - \"proc foo {} { puts \"hello\" }\", then an enterstep trace - would be invoked just before \"puts \"hello\"\" is executed. - Setting an enterstep trace on a command name that does not - refer to a procedure will not result in an error and is - simply ignored." - leavestep\ - " Invoke commandPrefix for every Tcl command which is executed - from the start of the execution of the procedure name until - that procedure finishes. CommandPrefix is invoked just after - the actual execution of the Tcl command being reported takes - place. Setting a leavestep trace on a command name that does - not refer to a procedure will not result in an error and is - simply ignored." - }\ - -help\ - "Indicates which operations are of interest." - commandPrefix -type string -help\ - "When the trace triggers, depending on the operation being traced, a - number of arguments are appended to commandPrefix so that the actual - command is as follows: For enter and enterstep operations: - ------------------------------- - commandPrefix command-string op - ------------------------------- - Command-string give the complete current command being executed - (the traced command for a enter operation, an arbitrary command - for an enterstep operation), including all arguments in their - fully expanded form. Op indicates what operation is being performed - on the command execution, and is on of enter or enterstep as - defined above. The trace operation can be used to stop the command - from executing, by deleting the command in question. Of course when - the command is subsequently executed, an \"invalid command\" error - will occur. + ${[example { + commandPrefix command-string op + }]} + Command-string give the complete current command being executed + (the traced command for a enter operation, an arbitrary command + for an enterstep operation), including all arguments in their + fully expanded form. Op indicates what operation is being performed + on the command execution, and is on of enter or enterstep as + defined above. The trace operation can be used to stop the command + from executing, by deleting the command in question. Of course when + the command is subsequently executed, an \"invalid command\" error + will occur. + For leave and leavestep operations: - ------------------------------------------- - commandPrefix command-string code result op - ------------------------------------------- - Command-string gives the complete current command being executed - (the traced command for a leave operation, an arbitrary command - for a leavestep operation), including all arguments in their - fully expanded form. Code give the result code of that execution, - and result the result string. Op indicates what operation is being - performed on the command execution and is one of leave or leavestep - as defined above. - - Note that the creation of many enterstep or leavestep traces can - lead to unintuitive results, since the invoked commands from one - trace can themselves lead to further command invocations for other - traces. - - CommandPrefix executes in the same context as the code that invoked - the traced operation: thus the commandPrefix, if invoked from a - procedure, will have access to the same local variables as code in the - procedure. This context may be different thatn the context in which - the trace was created. If commandPrefix invokes a procedure (which - it normally does) then the procedure will have to use upvar or uplevel - commands if it wishes to access the local variables of the code which - invoked the trace operation. - - While commandPrefix is executing during an execution trace, traces on - name are temporarily disabled. This allows the commandPrefix to execute - name in its body without invoking any other traces again. If an error - occurs while executing the commandPrefix, then the command name as a - whole will return that same error. - - When multiple traces are set on name, then for enter and enterstep - operations, the traced commands are invoked in the reverse order of how - the traces were originally created; and for leave and leavestep operations, - the traced commands are invoked in the original order of creation. - - The behaviour of execution traces is currently undefined for a command name - imported into another namespace. - " - } "@doc -name Manpage: -url [manpage_tcl trace]" - - punk::args::define { - @id -id "::trace remove" - @cmd -name "Built-in: trace remove"\ - -summary\ - "Remove a command, execution or variable trace."\ - -help\ - "Remove a command, execution or variable trace." - @form -synopsis "trace remove type name ops ?args?" - @leaders - type -choicegroups { - "" {command execution variable} - }\ - -choiceinfo { - command {{doctype punkargs} {subhelp ::trace remove command}} - execution {{doctype punkargs} {subhelp ::trace remove execution}} - variable {{doctype punkargs} {subhelp ::trace remove variable}} - } + ${[example { + commandPrefix command-string code result op + }]} + Command-string gives the complete current command being executed + (the traced command for a leave operation, an arbitrary command + for a leavestep operation), including all arguments in their + fully expanded form. Code give the result code of that execution, + and result the result string. Op indicates what operation is being + performed on the command execution and is one of leave or leavestep + as defined above. + + Note that the creation of many enterstep or leavestep traces can + lead to unintuitive results, since the invoked commands from one + trace can themselves lead to further command invocations for other + traces. + + CommandPrefix executes in the same context as the code that invoked + the traced operation: thus the commandPrefix, if invoked from a + procedure, will have access to the same local variables as code in the + procedure. This context may be different thatn the context in which + the trace was created. If commandPrefix invokes a procedure (which + it normally does) then the procedure will have to use upvar or uplevel + commands if it wishes to access the local variables of the code which + invoked the trace operation. + + While commandPrefix is executing during an execution trace, traces on + name are temporarily disabled. This allows the commandPrefix to execute + name in its body without invoking any other traces again. If an error + occurs while executing the commandPrefix, then the command name as a + whole will return that same error. + + When multiple traces are set on name, then for enter and enterstep + operations, the traced commands are invoked in the reverse order of how + the traces were originally created; and for leave and leavestep operations, + the traced commands are invoked in the original order of creation. + + The behaviour of execution traces is currently undefined for a command name + imported into another namespace. + " + } "@doc -name Manpage: -url [manpage_tcl trace]" + + punk::args::define { + @id -id "::trace remove" + @cmd -name "Built-in: trace remove"\ + -summary\ + "Remove a command, execution or variable trace."\ + -help\ + "Remove a command, execution or variable trace." + @form -synopsis "trace remove type name ops ?args?" + @leaders + type -choicegroups { + "" {command execution variable} + }\ + -choiceinfo { + command {{doctype punkargs} {subhelp ::trace remove command}} + execution {{doctype punkargs} {subhelp ::trace remove execution}} + variable {{doctype punkargs} {subhelp ::trace remove variable}} + } - } "@doc -name Manpage: -url [manpage_tcl trace]" - punk::args::define { - @id -id "::trace remove command" - @cmd -name "Built-in: trace remove command" -help\ - "If there is a trace set on command name with the operations and command - given by opList and commandPrefix, then the trace is removed, so that - commandPrefix will never again be invoked. Returns an empty string. If - name does not exist, the command will throw an error" - @values - name -type string -help\ - "Name of command" - opList -type list -help\ - "A list of one or more of the following items: - rename - delete" - commandPrefix - } "@doc -name Manpage: -url [manpage_tcl trace]" - - punk::args::define { - @id -id "::trace remove execution" - @cmd -name "Built-in: trace remove execution" -help\ - "If there is a trace set on command name with the operations and command - given by opList and commandPrefix, then the trace is removed, so that - commandPrefix will never again be invoked. Returns an empty string. If - name does not exist, the command will throw an error" - @values - name -type string -help\ - "Name of command" - opList -type list -help\ - "A list of one or more of the following items: - enter - leave - enterstep - leavestep" - commandPrefix - } "@doc -name Manpage: -url [manpage_tcl trace]" - - punk::args::define { - @id -id "::trace remove variable" - @cmd -name "Built-in: trace remove variable" -help\ - "If there is a trace set on command name with the operations and command - given by opList and commandPrefix, then the trace is removed, so that - commandPrefix will never again be invoked. Returns an empty string." - @values - name -type string -help\ - "Name of command" - opList -type list -help\ - "A list of one or more of the following items: - array - read - write - unset" - commandPrefix - } "@doc -name Manpage: -url [manpage_tcl trace]" + } "@doc -name Manpage: -url [manpage_tcl trace]" + punk::args::define { + @id -id "::trace remove command" + @cmd -name "Built-in: trace remove command" -help\ + "If there is a trace set on command name with the operations and command + given by opList and commandPrefix, then the trace is removed, so that + commandPrefix will never again be invoked. Returns an empty string. If + name does not exist, the command will throw an error" + @values + name -type string -help\ + "Name of command" + opList -type list -help\ + "A list of one or more of the following items: + rename + delete" + commandPrefix + } "@doc -name Manpage: -url [manpage_tcl trace]" + + punk::args::define { + @id -id "::trace remove execution" + @cmd -name "Built-in: trace remove execution" -help\ + "If there is a trace set on command name with the operations and command + given by opList and commandPrefix, then the trace is removed, so that + commandPrefix will never again be invoked. Returns an empty string. If + name does not exist, the command will throw an error" + @values + name -type string -help\ + "Name of command" + opList -type list -help\ + "A list of one or more of the following items: + enter + leave + enterstep + leavestep" + commandPrefix + } "@doc -name Manpage: -url [manpage_tcl trace]" + + punk::args::define { + @id -id "::trace remove variable" + @cmd -name "Built-in: trace remove variable" -help\ + "If there is a trace set on command name with the operations and command + given by opList and commandPrefix, then the trace is removed, so that + commandPrefix will never again be invoked. Returns an empty string." + @values + name -type string -help\ + "Name of command" + opList -type list -help\ + "A list of one or more of the following items: + array + read + write + unset" + commandPrefix + } "@doc -name Manpage: -url [manpage_tcl trace]" + + } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -10437,18 +11138,23 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { within which mount the mapping will be done; if omitted, the main root of the zipfs system is used." @leaders -min 0 -max 0 - @values -min 1 -max 1 + @values -min 1 -max 2 mountpoint -type string -optional 1 filename -type string } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::exists - @cmd -name "Built-in: ::zipfs::exists" -help\ + @cmd -name "Built-in: ::zipfs::exists"\ + -summary\ + "Test zipfs file path exists."\ + -help\ "Return 1 if the given filename exists in the mounted zipfs and 0 if it does not." @leaders -min 0 -max 0 @values -min 1 -max 1 - filename -type file + filename -type file -help\ + "e.g + zipfs exists //zipfs:/app/main.tcl" } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zipfs]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @@ -10465,7 +11171,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::info - @cmd -name "Built-in: ::zipfs::info" -help\ + @cmd -name "Built-in: ::zipfs::info"\ + -summary\ + "File's ZIPfile,size,compressed-size,offset."\ + -help\ "Return information about the given ${$I}file${$NI} in the mounted zipfs. The information consists of: 1. the name of the ZIP archive file that contains the file, @@ -10518,7 +11227,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::lmkimg - @cmd -name "Built-in: ::zipfs::lmkimg" -help\ + @cmd -name "Built-in: ::zipfs::lmkimg"\ + -summary\ + "Create executable ZIP archive from list of {filename filepath} items."\ + -help\ "This command is like ${$B}zipfs mkimg${$N}, but instead of an input directory, ${$I}inlist${$NI} must be a Tcl list where the odd elements are the names of files to be copied into the archive in the image, and the even elements are @@ -10533,7 +11245,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::lmkzip - @cmd -name "Built-in: ::zipfs::lmkzip" -help\ + @cmd -name "Built-in: ::zipfs::lmkzip"\ + -summary\ + "Create ZIP archive from list of {filename filepath} items."\ + -help\ "This command is like ${$B}zipfs mkzip${$N}, but instead of an input directory, ${$I}inlist${$NI} must be a Tcl list where the odd elements are the names of files to be copied into the archive, and the even elements are their respective @@ -10547,7 +11262,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::mount - @cmd -name "Built-in: ::zipfs::mount" -help\ + @cmd -name "Built-in: ::zipfs::mount"\ + -summary\ + "Query mountpoint(s) or mount an archive."\ + -help\ "The ${$B}zipfs mount${$N} command mounts ZIP archives as Tcl virtual file systems and returns information about current mounts. @@ -10607,7 +11325,7 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { @id -id ::tcl::zipfs::mkzip @cmd -name "Built-in: ::zipfs::mkzip"\ -summary\ - "Create a ZIP archive."\ + "Create ZIP archive."\ -help\ "Creates a ZIP archive file named outfile from the contents of the input directory indir (contained regular files only) with optional ZIP password @@ -10628,7 +11346,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::mkimg - @cmd -name "Built-in: ::zipfs::mkimg" -help\ + @cmd -name "Built-in: ::zipfs::mkimg"\ + -summary\ + "Create executable ZIP archive."\ + -help\ "Creates an image (potentially a new executable file) similar to ${$B}zipfs mkzip${$N}; see that command for a description of most parameters to this command, as they behave identically here. If outfile exists, it will be silently @@ -10670,7 +11391,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::mkkey - @cmd -name "Built-in: ::zipfs::mkzip" -help\ + @cmd -name "Built-in: ::zipfs::mkzip"\ + -summary\ + "password to zipfs mildly-obfuscated string."\ + -help\ "Given the clear text ${$I}password${$NI} argument, an obfuscated string version is returned with the same format used in the ${$B}zipfs mkimg${$N} command." @leaders -min 0 -max 0 @@ -10680,7 +11404,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::root - @cmd -name "Built-in: ::zipfs::root" -help\ + @cmd -name "Built-in: ::zipfs::root"\ + -summary\ + "zipfs root mount point."\ + -help\ "Returns a constant string which indicates the mount point for zipfs volumes for the current platform. User should not rely on the mount point being the same constant string for all platforms." @@ -10691,7 +11418,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::unmount - @cmd -name "Built-in: ::zipfs::unmount" -help\ + @cmd -name "Built-in: ::zipfs::unmount"\ + -summary\ + "Unmount zipfs mountpoint."\ + -help\ "Unmounts a previously mounted ZIP archive mounted to ${$I}mountpoint${$NI}. The command will fail with an error exception if there are any files within the mounted archive are open." diff --git a/src/modules/punk/args/moduledoc/tkcore-999999.0a1.0.tm b/src/modules/punk/args/moduledoc/tkcore-999999.0a1.0.tm index 8d6d3e6e..9d7b3d62 100644 --- a/src/modules/punk/args/moduledoc/tkcore-999999.0a1.0.tm +++ b/src/modules/punk/args/moduledoc/tkcore-999999.0a1.0.tm @@ -111,6 +111,8 @@ tcl::namespace::eval punk::args::moduledoc::tkcore { set NI [a+ noitalic] set B [a+ bold] set N [a+ normal] + set T [a+ bold underline] + set NT [a+ normal nounderline] # -- --- --- --- --- namespace import ::punk::args::helpers::* @@ -512,6 +514,7 @@ tcl::namespace::eval punk::args::moduledoc::tkcore { punk::args::define { @id -id (widgetcommand)Class_Button + # ?? (instance)Class_Button ?? @cmd -name "Tk widget: (widgetcommand)Class_Button"\ -summary\ "widgetcommand for Tk class Button"\ @@ -531,6 +534,318 @@ tcl::namespace::eval punk::args::moduledoc::tkcore { + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # ::wm subcommands + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id "::wm aspect" + @cmd -name "Tk Built-in: ::wm aspect"\ + -summary\ + "Get/set aspect ratio restrictions."\ + -help\ + "If ${$I}minNumer${$NI}, ${$I}minDenom${$NI}, ${$I}maxNumer${$NI}, and ${$I}maxDenom${$NI} are all specified, then they will be passed to + the window manager and the window manager should use them to enforce a range of acceptable + aspect ratios for window. The aspect ratio of window (width/length) will be constrained to lie + between ${$I}minNumer${$NI}/${$I}minDenom${$NI} and ${$I}maxNumer${$NI}/${$I}maxDenom${$NI}. If ${$I}minNumer${$NI} etc. are all specified as empty + strings, then any existing aspect ratio restrictions are removed. If ${$I}minNumer${$NI} etc. are + specified, then the command returns an empty string. Otherwise, it returns a Tcl list + containing four elements, which are the current values of ${$I}minNumer${$NI}, ${$I}minDenom${$NI}, ${$I}maxNumer${$NI}, and + ${$I}maxDenom${$NI} (if no aspect restrictions are in effect, then an empty string is returned)." + @values -min 1 + window -type string + #todo - punk::args - way to specify all number or all empty e.g + # -type {(number number number number)|(literal() literal() literal() literal())} + aspectratio\ + -type {number|literal() number|literal() number|literal() number|literal()}\ + -typesynopsis "${$I}minNumer${$NI} ${$I}minDenom${$NI} ${$I}maxNumer${$NI} ${$I}maxDenom${$NI}"\ + -optional 1 + } "@doc -name Manpage: -url [manpage wm]" + + #attributes + + punk::args::define { + @id -id "::wm client" + @cmd -name "Tk Built-in: ::wm client"\ + -summary\ + "Get/set WM_CLIENT_MACHINE name for the window."\ + -help\ + "If ${$I}name${$NI} is specified, this command stores ${$I}name${$NI} (which should be the name of the host on which the application + is executing) in ${$I}window${$NI}'s ${$B}WM_CLIENT_MACHINE${$N} property for use by the window manager or session manager. The + command returns an empty string in this case. If ${$I}name${$NI} is not specified, the command returns the last name set + in a wm client command for window. If ${$I}name${$NI} is specified as an empty string, the command deletes the + ${$B}WM_CLIENT_MACHINE${$N} property from ${$I}window${$NI}." + @values -min 1 -max 2 + window -type string + name\ + -type string\ + -optional 1 + } "@doc -name Manpage: -url [manpage wm]" + + #colormapwindows + #command + #deiconify + #focusmodel + + punk::args::define { + @id -id "::wm forget" + @cmd -name "Tk Built-in: ::wm forget"\ + -summary\ + "Unmap/Unmanage window."\ + -help\ + "The window will be unmapped from the screen and will no longer be managed by ${$B}wm${$N}. Windows created with the + ${$B}toplevel${$N} command will be treated like frame windows once they are no longer managed by ${$B}wm${$N}, however, the + ${$B}-menu${$N} configuration will be remembered and the menus will return once the widget is managed again." + @values -min 1 -max 1 + window -type string + } "@doc -name Manpage: -url [manpage wm]" + + punk::args::define { + @id -id "::wm frame" + @cmd -name "Tk Built-in: ::wm frame"\ + -summary\ + "Identifier of outermost frame containing window."\ + -help\ + "If ${$I}window${$NI} has been reparented by the window manager into a decorative frame, the command returns the + platform specific window identifier for the outermost frame that contains ${$I}window${$NI} (the window whose parent + is the root or virtual root). If ${$I}window${$NI} has not been reparented by the window manager then the command + returns the platform specific window identifier for ${$I}window${$NI}." + @values -min 1 -max 1 + window -type string + } "@doc -name Manpage: -url [manpage wm]" + + #geometry + #grid + #group + #iconbadge + #iconbitmap + #iconify + #iconmask + #iconname + #iconphoto + #iconposition + #iconwindow + punk::args::define { + @id -id "::wm manage" + @cmd -name "Tk Built-in: ::wm manage"\ + -summary\ + "Make frame/labelframe a toplevel."\ + -help\ + "The ${$I}widget${$NI} specified will become a stand alone top-level window. The window will be decorated with the window + managers title bar, etc. Only frame, labelframe and toplevel widgets can be used with this command. Attempting + to pass any other widget type will raise an error. Attempting to manage a toplevel widget is benign and achieves + nothing. See also ${$B}GEOMETRY MANAGEMENT${$N}." + @values -min 1 -max 1 + widget -type string -help\ + "frame, labelframe or toplevel" + } "@doc -name Manpage: -url [manpage wm]" + + #maxsize + #minsize + #overrideredirect + #positionfrom + #protocol + punk::args::define { + @id -id "::wm resizable" + @cmd -name "Tk Built-in: ::wm resizable"\ + -summary\ + "Get/Set window width and height resizability."\ + -help\ + "This command controls whether or not the user may interactively resize a top-level window. If ${$I}width${$NI} and ${$I}height${$NI} are + specified, they are boolean values that determine whether the width and height of window may be modified by the user. + In this case the command returns an empty string. If ${$I}width${$NI} and ${$I}height${$NI} are omitted then the command returns a list + with two 0/1 elements that indicate whether the width and height of window are currently resizable. By default, + windows are resizable in both dimensions. If resizing is disabled, then the window's size will be the size from the + most recent interactive resize or ${$B}wm geometry${$N} command. If there has been no such operation then the window's natural + size will be used." + @values -min 1 + window -type string + width_height\ + -type {boolean boolean}\ + -typesynopsis "${$I}width${$NI} ${$I}height${$NI}"\ + -optional 1 + } "@doc -name Manpage: -url [manpage wm]" + #sizefrom + #stackorder + punk::args::define { + @id -id "::wm state" + @cmd -name "Tk Built-in: ::wm state"\ + -summary\ + "Get/set window state."\ + -help\ + "If newstate is specified, the window will be set to the new state, otherwise it returns the current state of window: + either ${$B}normal${$N}, ${$B}iconic${$N}, ${$B}withdrawn${$N}, ${$B}icon${$N}, or (Windows and macOS only) ${$B}zoomed${$N}. The difference between ${$B}iconic${$N} and ${$B}icon${$N} is + that ${$B}iconic${$N} refers to a window that has been iconified (e.g., with the wm iconify command) while ${$B}icon${$N} refers to a + window whose only purpose is to serve as the icon for some other window (via the ${$B}wm iconwindow${$N} command). + The ${$B}icon${$N} state cannot be set." + @values -min 1 -max 2 + window -type string + newstate\ + -type string\ + -optional 1\ + -choices {normal iconic withdrawn zoomed}\ + -choicelabels {\ + normal\ + "" + iconic\ + "" + withdrawn\ + "" + zoomed\ + " (Windows and macOS only)" + } + + } "@doc -name Manpage: -url [manpage wm]" + #title + #transient + #withdraw + + + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # ::wm + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set WM_CHOICES [list aspect attributes client colormapwindows command deiconify focusmodel forget frame\ + geometry grid group iconbadge iconbitmap iconify iconmask iconname iconphoto iconposition iconwindow\ + manage maxsize minsize overrideredirect positionfrom protocol resizable sizefrom stackorder\ + state title transient withdraw\ + ] + #manual synopses for subcommands not yet defined + set WM_CHOICELABELS [subst -novariables { + }] + set WM_CHOICEGROUPS [dict create\ + "" {}\ + icon {iconbadge iconbitmap iconmask iconphoto iconposition iconwindow}\ + ] + set WM_GROUPALLOCATED [list] + dict for {g glist} $WM_CHOICEGROUPS { + lappend WM_GROUPALLOCATED {*}$glist + } + foreach sub $WM_CHOICES { + if {$sub ni $WM_GROUPALLOCATED} { + dict lappend WM_CHOICEGROUPS "" $sub + } + } + set WM_CHOICEINFO [dict create] + foreach sub $WM_CHOICES { + #default for all + dict set WM_CHOICEINFO $sub {{doctype native}} + } + foreach id [punk::args::get_ids "::wm *"] { + if {[llength $id] == 2} { + lassign $id _ sub + dict set WM_CHOICEINFO $sub {{doctype native} {doctype punkargs}} + #override manual synopsis entry + #puts stderr "override manual synopsis entry with [punk::ns::synopsis "::wm $sub"]" + dict set WM_CHOICELABELS $sub [punk::ansi::a+ normal][punk::args::synopsis "::wm $sub"] + } + } + + punk::args::define { + @id -id ::wm + @cmd -name "Tk Built-in: ::wm"\ + -summary\ + "Communicate with window manager."\ + -help\ + "The ${$B}wm${$N} command is used to interact with window managers in order to control such things as the + title for a window, its geometry, or the increments in terms of which it may be resized. The ${$B}wm${$N} + command can take any of a number of different forms, depending on the option argument. All of + the forms expect at least one additional argument, window, which must be the path name of a + top-level window. + + ${$T}GEOMETRY MANAGMENT${$NT} + By default a top-level window appears on the screen in its natural size, which is the one determined internally + by its widgets and geometry managers. If the natural size of a top-level window changes, then the window's size + changes to match. A top-level window can be given a size other than its natural size in two ways. First, the + user can resize the window manually using the facilities of the window manager, such as resize handles. Second, + the application can request a particular size for a top-level window using the wm geometry command. These two + cases are handled identically by Tk; in either case, the requested size overrides the natural size. You can + return the window to its natural by invoking wm geometry with an empty geometry string. + + Normally a top-level window can have any size from one pixel in each dimension up to the size of its screen. + However, you can use the wm minsize and wm maxsize commands to limit the range of allowable sizes. The range + set by wm minsize and wm maxsize applies to all forms of resizing, including the window's natural size as well + as manual resizes and the wm geometry command. You can use any value accepted by Tk_GetPixels. You can also use + the command wm resizable to completely disable interactive resizing in one or both dimensions. + + The wm manage and wm forget commands may be used to perform undocking and docking of windows. After a widget is + managed by wm manage command, all other wm subcommands may be used with the widget. Only widgets created using + the toplevel command may have an attached menu via the -menu configure option. A toplevel widget may be used as + a frame and managed with any of the other geometry managers after using the wm forget command. Any menu + associated with a toplevel widget will be hidden when managed by another geometry managers. The menus will + reappear once the window is managed by wm. All custom bindtags for widgets in a subtree that have their top-level + widget changed via a wm manage or wm forget command, must be redone to adjust any top-level widget path in the + bindtags. Bindtags that have not been customized do not have to be redone. + + ${$T}GRIDDED GEOMETRY MANAGEMENT${$NT} + Gridded geometry management occurs when one of the widgets of an application supports a range of useful sizes. + This occurs, for example, in a text editor where the scrollbars, menus, and other adornments are fixed in size but + the edit widget can support any number of lines of text or characters per line. In this case, it is usually + desirable to let the user specify the number of lines or characters-per-line, either with the wm geometry command + or by interactively resizing the window. In the case of text, and in other interesting cases also, only discrete + sizes of the window make sense, such as integral numbers of lines and characters-per-line; arbitrary pixel sizes + are not useful. + + Gridded geometry management provides support for this kind of application. Tk (and the window manager) assume that + there is a grid of some sort within the application and that the application should be resized in terms of grid + units rather than pixels. Gridded geometry management is typically invoked by turning on the setGrid option for a + widget; it can also be invoked with the wm grid command or by calling Tk_SetGrid. In each of these approaches the + particular widget (or sometimes code in the application as a whole) specifies the relationship between integral + grid sizes for the window and pixel sizes. To return to non-gridded geometry management, invoke wm grid with empty + argument strings. + + When gridded geometry management is enabled then all the dimensions specified in wm minsize, wm maxsize, and + wm geometry commands are treated as grid units rather than pixel units. Interactive resizing is also carried out in + even numbers of grid units rather than pixels. + + ${$T}BUGS${$NT} + Most existing window managers appear to have bugs that affect the operation of the ${$B}wm${$N} command. For example, + some changes will not take effect if the window is already active: the window will have to be withdrawn and + de-iconified in order to make the change happen." + @leaders -min 1 -max 1 + subcommand -type string\ + -choicecolumns 2\ + -choicegroups\ + {${$WM_CHOICEGROUPS}}\ + -unindentedfields {-choicelabels}\ + -choicelabels\ + {${$WM_CHOICELABELS}}\ + -choiceinfo {${$WM_CHOICEINFO}} + @values -unnamed true + } "@doc -name Manpage: -url [manpage wm]"\ + { + @examples -help { + A fixed-size window that says that it is fixed-size too: + ${[example { + toplevel .fixed + ${$B}wm title${$N} .fixed "Fixed-size Window" + ${$B}wm resizable${$N} .fixed 0 0 + }]} + A simple dialog-like window, centred on the screen: + ${[example { + # Create and arrange the dialog contents. + toplevel .msg + label .msg.l -text "This is a very simple dialog demo." + button .msg.ok -text OK -default active -command {destroy .msg} + pack .msg.ok -side bottom -fill x + pack .msg.l -expand 1 -fill both + + # Now set the widget up as a centred dialog. + + # But first, we need the geometry managers to finish setting + # up the interior of the dialog, for which we need to run the + # event loop with the widget hidden completely... + ${$B}wm withdraw${$N} .msg + update + set x [expr {([winfo screenwidth .] - [winfo width .msg]) / 2}] + set y [expr {([winfo screenheight .] - [winfo height .msg]) / 2}] + ${$B}wm geometry${$N} .msg +$x+$y + ${$B}wm transient${$N} .msg . + ${$B}wm title${$N} .msg "Dialog demo" + ${$B}wm deiconify${$N} .msg + }]} + }} + + } #*** !doctools diff --git a/src/modules/punk/assertion-999999.0a1.0.tm b/src/modules/punk/assertion-999999.0a1.0.tm index 627546a9..eac10905 100644 --- a/src/modules/punk/assertion-999999.0a1.0.tm +++ b/src/modules/punk/assertion-999999.0a1.0.tm @@ -66,38 +66,6 @@ package require Tcl 8.6- #*** !doctools #[section API] -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::assertion::class { - #*** !doctools - #[subsection {Namespace punk::assertion::class}] - #[para] class definitions - if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { - #*** !doctools - #[list_begin enumerated] - - # oo::class create interface_sample1 { - # #*** !doctools - # #[enum] CLASS [class interface_sample1] - # #[list_begin definitions] - - # method test {arg1} { - # #*** !doctools - # #[call class::interface_sample1 [method test] [arg arg1]] - # #[para] test method - # puts "test: $arg1" - # } - - # #*** !doctools - # #[list_end] [comment {-- end definitions interface_sample1}] - # } - - #*** !doctools - #[list_end] [comment {--- end class enumeration ---}] - } -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #keep 2 namespaces for assertActive and assertInactive so there is introspection available via namespace origin tcl::namespace::eval punk::assertion::primary { @@ -149,9 +117,13 @@ tcl::namespace::eval punk::assertion { proc do_ns_import {} { uplevel 1 [list tcl::namespace::import ::punk::assertion::primary::assertActive] } - do_ns_import #puts --------BBB - rename assertActive assert + if {[catch { + do_ns_import + rename assertActive assert + } errM]} { + puts stderr "punk::assertion error during load - assert/assertActive functions already present?\n$errM" + } } diff --git a/src/modules/punk/du-999999.0a1.0.tm b/src/modules/punk/du-999999.0a1.0.tm index 56e38fd2..2ac4389b 100644 --- a/src/modules/punk/du-999999.0a1.0.tm +++ b/src/modules/punk/du-999999.0a1.0.tm @@ -961,9 +961,9 @@ namespace eval punk::du { proc get_vfsmounts_in_folder {folderpath} { set vfsmounts [list] if {![llength [package provide vfs]]} { - return [list] + return [list] } - set fpath [punk::objclone $folderpath] + set fpath [punk::valcopy $folderpath] set is_rel 0 if {[file pathtype $fpath] ne "absolute"} { set fpath [file normalize $fpath] diff --git a/src/modules/punk/lib-999999.0a1.0.tm b/src/modules/punk/lib-999999.0a1.0.tm index 24da0194..be3ed06a 100644 --- a/src/modules/punk/lib-999999.0a1.0.tm +++ b/src/modules/punk/lib-999999.0a1.0.tm @@ -4071,11 +4071,11 @@ namespace eval punk::lib { interp eval $interp [list tcl::tm::add {*}[lreverse [tcl::tm::list]]] } - proc objclone {obj} { + proc valcopy {obj} { append obj2 $obj {} } - proc set_clone {varname obj} { - #used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_clone varnmame $val] + proc set_valcopy {varname obj} { + #used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_valcopy varnmame $val] append obj2 $obj {} uplevel 1 [list set $varname $obj2] } @@ -4095,9 +4095,9 @@ namespace eval punk::lib { set default_groupsize 3 set results [list] - set nums [objclone $numbers_or_commaformattednumbers] ;#stops single num from getting internal rep of list + set nums [valcopy $numbers_or_commaformattednumbers] ;#stops single num from getting internal rep of list foreach inputnum $nums { - set number [objclone $inputnum] + set number [valcopy $inputnum] #also handle tcl 8.7+ underscores in numbers set number [string map [list _ "" , ""] $number] #normalize e.g 2e4 -> 20000.0 @@ -4145,7 +4145,7 @@ namespace eval punk::lib { # and possibly containing a decimal point, i.e.: [:space:]*[:digit:]*\.[:digit:]* proc delimit_number {unformattednumber {delim ","} {GroupSize 3}} { - set number [objclone $unformattednumber] + set number [valcopy $unformattednumber] set number [string map {_ ""} $number] #normalize using expr - e.g 2e4 -> 20000.0 set number [expr {$number}] diff --git a/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm b/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm index 9feaba21..4059f44b 100644 --- a/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm @@ -34,7 +34,7 @@ namespace eval punk::mix::commandset::loadedlib { "(unimplemented) Display only those that are 0:absent 1:present 2:either" -highlight -type boolean -default 1 -help\ "Highlight which version is present with ansi underline and colour" - -refresh -default 0 -type boolean -help "Re-scan the tm and library folders" + -refresh -type none -help "Re-scan the tm and library folders" searchstring -default * -multiple 1 -help\ "Names to search for, may contain glob chars (* ?) e.g *lib* If no glob chars are explicitly specified, the searchstring will be wrapped with star globs. @@ -45,11 +45,11 @@ namespace eval punk::mix::commandset::loadedlib { } proc search {args} { set argd [punk::args::parse $args withid ::punk::mix::commandset::loadedlib::search] - set searchstrings [dict get $argd values searchstring] - set opts [dict get $argd opts] + lassign [dict values $argd] leaders opts values received + set searchstrings [dict get $values searchstring] set opt_return [dict get $opts -return] set opt_highlight [dict get $opts -highlight] - set opt_refresh [dict get $opts -refresh] + set opt_refresh [dict exists $received -refresh] if {$opt_refresh} { catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything REVIEW - this doesn't result in full scans diff --git a/src/modules/punk/ns-999999.0a1.0.tm b/src/modules/punk/ns-999999.0a1.0.tm index a961e6cd..62fd8435 100644 --- a/src/modules/punk/ns-999999.0a1.0.tm +++ b/src/modules/punk/ns-999999.0a1.0.tm @@ -26,6 +26,28 @@ package require punk::args tcl::namespace::eval ::punk::ns::evaluator { #eval-_NS_xxx_NS_etc procs } +tcl::namespace::eval punk::ns { + namespace eval argdoc { + variable PUNKARGS + tcl::namespace::import ::punk::ansi::a+ ::punk::ansi::a + # -- --- --- --- --- + #non colour SGR codes + # we can use these directly via ${$I} etc without marking a definition with @dynamic + #This is because they don't need to change when colour switched on and off. + set I [a+ italic] + set NI [a+ noitalic] + set B [a+ bold] + set N [a+ normal] + set T [a+ bold underline] + set NT [a+ normal nounderline] + set LC \u007b ;#left curly brace + set RC \u007d ;#right curly brace + # -- --- --- --- --- + + namespace import ::punk::args::helpers::* + + } +} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::ns { @@ -3088,7 +3110,7 @@ tcl::namespace::eval punk::ns { }] append argdef \n $vline append argdef \n "@values -unnamed true" - append argdef \n "@instance -help {instance info derived from id (instance)::$origin ?}" + append argdef \n "@instance -help {instance info derived from id (instance)$origin ?}" punk::args::define $argdef } @@ -4184,1171 +4206,1193 @@ tcl::namespace::eval punk::ns { # - as this is interactive generally introspection should be ok at the top level # but if we need to go down multiple levels of subcommands generating/testing prefixes - could be an issue ?? #TODO - make obsolete - (replaced by punk::ns::cmdhelp) - punk::args::define { - @dynamic - @id -id ::punk::ns::arginfo - @cmd -name punk::ns::arginfo\ - -summary\ - "Command usage/help."\ - -help\ - "Show usage info for a command. - It supports the following: - 1) Procedures or builtins for which a punk::args definition has - been loaded. - 2) tepam procedures (returns string form only) - 3) ensemble commands - auto-generated unless documented via punk::args - (subcommands will show with an indicator if they are - explicitly documented or are themselves ensembles) - 4) tcl::oo objects - auto-gnerated unless documented via punk::args - 5) dereferencing of aliases to find underlying command - (will not work with some renamed aliases) + #punk::args::define { + # @dynamic + # @id -id ::punk::ns::arginfo + # @cmd -name punk::ns::arginfo\ + # -summary\ + # "Command usage/help."\ + # -help\ + # "Show usage info for a command. + # It supports the following: + # 1) Procedures or builtins for which a punk::args definition has + # been loaded. + # 2) tepam procedures (returns string form only) + # 3) ensemble commands - auto-generated unless documented via punk::args + # (subcommands will show with an indicator if they are + # explicitly documented or are themselves ensembles) + # 4) tcl::oo objects - auto-gnerated unless documented via punk::args + # 5) dereferencing of aliases to find underlying command + # (will not work with some renamed aliases) + + # Note that native commands commands not explicitly documented will + # generally produce no useful info. For example sqlite3 dbcmd objects + # could theoretically be documented - but as 'info cmdtype' just shows + # 'native' they can't (?) be identified as belonging to sqlite3 without + # calling them. arginfo deliberately avoids calling commands to elicit + # usage information as this is inherently risky. (could create a file, + # exit the interp etc) + # " + # -return -type string -default table -choices {string table tableobject} + + + # } {${[punk::args::resolved_def -types opts ::punk::args::arg_error -scheme]}} { + # -form -default 0 -help\ + # "Ordinal index or name of command form" + # -grepstr -default "" -type list -typesynopsis regex -help\ + # "list consisting of regex, optionally followed by ANSI names for highlighting + # (incomplete - todo)" + # -- -type none -help\ + # "End of options marker + # Use this if the command to view begins with a -" + # @values -min 1 + # commandpath -help\ + # "command (may be alias, ensemble, tcl::oo object, tepam proc etc)" + # subcommand -optional 1 -multiple 1 -default {} -help\ + # "subcommand if commandpath is an ensemble. + # Multiple subcommands can be supplied if ensembles are further nested" + #} + #proc arginfo {args} { + # lassign [dict values [punk::args::parse $args withid ::punk::ns::arginfo]] leaders opts values received + # set nscaller [uplevel 1 [list ::namespace current]] + # #review - setting this afterwards is an architecture smell - we should be able to override the default in the dynamic part + # #todo - enable retrieving by id just the record_opts part - so we can treat as a dict directly, as well as easily apply it as a different flag name. + # if {![dict exists $received -scheme]} { + # #dict set opts -scheme info + # set scheme_received 0 + # } else { + # set scheme_received 1; #so we know not to override caller's explicit choice + # } + + # set querycommand [dict get $values commandpath] + # set queryargs [dict get $values subcommand] + # set grepstr [dict get $opts -grepstr] + # set opts [dict remove $opts -grepstr] + # #puts stdout "---------------------arginfo: '$args' querycommand:'$querycommand' queryargs:'$queryargs'" + + # #todo - similar to corp? review corp resolution process + # #should handle lazy loaded commands (via ::auto_index) that are not yet present but may be documented + + # set cinfo [uplevel 1 [list cmdwhich $querycommand]] + # set origin [dict get $cinfo origin] + # set resolved [dict get $cinfo which] + # set cmdtype [dict get $cinfo origintype] + # switch -- $cmdtype { + # script { + # #assumed to be an 'alias' script - ie proper list - not an arbitrary tcl code block + # set scriptargs [lrange $origin 1 end] ;#arguments that were curried into the alias script + # set origin [lindex $origin 0] + # set queryargs [list {*}$scriptargs {*}$queryargs] + # return [uplevel 1 [list punk::ns::arginfo {*}$opts $origin {*}$queryargs]] + # } + # alias { + # #alias to an alias + # return [uplevel 1 [list punk::ns::arginfo {*}$opts $origin {*}$queryargs]] + # } + # } + + # #JJJ + # #check for a direct match first + # if {![llength $queryargs]} { + # #puts stderr "---->arginfo '$args' update_definitions [list [namespace qualifiers $origin]]" + # punk::args::update_definitions [list [namespace qualifiers $origin]] ;#update_definitions will treat empty string as global ns :: + # if {![punk::args::id_exists $origin] && ![punk::args::id_exists (autodef)$origin]} { + # uplevel 1 [list punk::ns::generate_autodef $origin] + # } + + # if {[punk::args::id_exists (autodef)$origin]} { + # set origin (autodef)$origin + # } + # if {[punk::args::id_exists $origin]} { + # switch -- [dict get $opts -return] { + # string { + # set estyle "basic" + # } + # tableobject { + # set estyle "minimal" + # } + # default { + # set estyle "standard" + # } + # } + # if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid $origin} parseresult]} { + # if {[dict get $opts -return] eq "tableobject"} { + # return [punk::args::arg_error "$parseresult" [punk::args::get_spec $origin] {*}$opts -aserror 0] + # } else { + # return $parseresult + # } + # } else { + # if {!$scheme_received} { + # dict set opts -scheme info + # } + # return [punk::args::arg_error "" [punk::args::get_spec $origin] {*}$opts -aserror 0 -parsedargs $parseresult] + # } + # } + # } + + + # set id $origin + # #puts stderr "____>arginfo '$args' update_definitions [list [namespace qualifiers $id]]" + # punk::args::update_definitions [list [namespace qualifiers $id]] + + + # #check longest first checking for id matching ::cmd ?subcmd..? + # #REVIEW - this doesn't cater for prefix callable subcommands + # if {[llength $queryargs]} { + # if {[punk::args::id_exists [list $id {*}$queryargs]]} { + # switch -- [dict get $opts -return] { + # string { + # set estyle "basic" + # } + # tableobject { + # set estyle "minimal" + # } + # default { + # set estyle "standard" + # } + # } + # if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid [list $id {*}$queryargs]} parseresult]} { + # if {[dict get $opts -return] eq "tableobject"} { + # return [punk::args::arg_error "$parseresult" [punk::args::get_spec [list $id {*}$queryargs]] {*}$opts -aserror 0] + # } else { + # return $parseresult + # } + # } else { + # if {!$scheme_received} { + # dict set opts -scheme info + # } + # return [punk::args::arg_error "" [punk::args::get_spec [list $id {*}$queryargs]] {*}$opts -aserror 0 -parsedargs $parseresult] + # #return [uplevel 1 [list punk::args::usage {*}$opts [list $id {*}$queryargs]]] + # } + # } + # } + + # #didn't find any exact matches + # #traverse from other direction taking prefixes into account + # set specid "" + # if {[punk::args::id_exists $id]} { + # set specid $id + # } elseif {[punk::args::id_exists (autodef)$id]} { + # set specid (autodef)$id + # } + + # if {$specid ne "" && [punk::args::id_exists $specid]} { + # #cycle forward through leading values + # set specargs $queryargs + # if {[llength $queryargs]} { + # #jjj + # set spec [punk::args::get_spec $specid] + # #--------------------------------------------------------------------------- + # set form_names [dict get $spec form_names] + # if {[llength $form_names] == 1} { + # set fid [lindex $form_names 0] + # } else { + # #review - -form only applies to final command? + # # -form must be a list if we have multiple levels of multi-form commands? + # set opt_form [dict get $opts -form] + # if {[string is integer -strict $opt_form]} { + # if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { + # error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + # } + # set fid [lindex $form_names $opt_form] + # } else { + # if {$opt_form ni $form_names} { + # error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + # } + # set fid $opt_form + # } + # } + # #--------------------------------------------------------------------------- + # set nextqueryargs [list] ;#build a list of prefix-resolved queryargs + # set queryargs_untested $queryargs + # foreach q $queryargs { + # if {[llength [dict get $spec FORMS $fid LEADER_NAMES]]} { + # #todo: fix + # set subitems [dict get $spec FORMS $fid LEADER_NAMES] + # if {[llength $subitems]} { + # set next [lindex $subitems 0] + # set arginfo [dict get $spec FORMS $fid ARG_INFO $next] + + # set allchoices [list] + # set choices [punk::args::system::Dict_getdef $arginfo -choices {}] + # set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}] + # #maintenance smell - similar/dup of some punk::args logic - review + # #-choiceprefixdenylist ?? + # set choiceprefixreservelist [punk::args::system::Dict_getdef $arginfo -choiceprefixreservelist {}] + # if {[dict exists $choicegroups ""]} { + # dict lappend choicegroups "" {*}$choices + # } else { + # set choicegroups [dict merge [dict create "" $choices] $choicegroups] + # } + # dict for {groupname clist} $choicegroups { + # lappend allchoices {*}$clist + # } + # set resolved_q [tcl::prefix::match -error "" [list {*}$allchoices {*}$choiceprefixreservelist] $q] + # if {$resolved_q eq "" || $resolved_q in $choiceprefixreservelist} { + # break + # } + # lappend nextqueryargs $resolved_q + # lpop queryargs_untested 0 + # #ledit queryargs_untested 0 0 + # if {$resolved_q ne $q} { + # #we have our first difference - recurse with new query args + # #set numvals [expr {[llength $queryargs]+1}] + # #return [ punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$nextqueryargs {*}$queryargs_untested] + # #puts "===> testing arginfo {*}$opts $querycommand {*}$nextqueryargs {*}$queryargs_untested" + # if {!$scheme_received} { + # dict unset opts -scheme + # } + # return [ punk::ns::arginfo {*}$opts {*}$specid {*}$nextqueryargs {*}$queryargs_untested] + + # } + # #check if subcommands so far have a custom args def + # #set currentid [list $querycommand {*}$nextqueryargs] + # set currentid [list {*}$specid {*}$nextqueryargs] + # if {[punk::args::id_exists $currentid]} { + # set spec [punk::args::get_spec $currentid] + # #--------------------------------------------------------------------------- + # set form_names [dict get $spec form_names] + # if {[llength $form_names] == 1} { + # set fid [lindex $form_names 0] + # } else { + # #review - -form only applies to final command? + # # -form must be a list if we have multiple levels of multi-form commands? + # set opt_form [dict get $opts -form] + # if {[string is integer -strict $opt_form]} { + # if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { + # error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + # } + # set fid [lindex $form_names $opt_form] + # } else { + # if {$opt_form ni $form_names} { + # error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + # } + # set fid $opt_form + # } + # } + # #--------------------------------------------------------------------------- + # set specid $currentid + # set specargs $queryargs_untested + # set nextqueryargs [list] + # } else { + # #We can get no further with custom defs + # #It is possible we have a documented lower level subcommand but missing the intermediate + # #e.g if ::trace remove command was specified and is documented - it will be found above + # #but if ::trace remove is not documented and the query is "::trace remove com" + # #There is no way to determine com is a prefix as we don't have the intermediate documented -choice info available. + # #that's probably ok. + # break + # } + # } + # } else { + # #review + # break + # } + # } + # } else { + # switch -- [dict get $opts -return] { + # string { + # set estyle "basic" + # } + # tableobject { + # set estyle "minimal" + # } + # default { + # set estyle "standard" + # } + # } + # if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid $id} parseresult]} { + # if {[dict get $opts -return] eq "tableobject"} { + # return [punk::args::arg_error "$parseresult" [punk::args::get_spec $id] {*}$opts -aserror 0] + # } else { + # return $parseresult + # } + # } else { + # if {!$scheme_received} { + # dict set opts -scheme info + # } + # return [punk::args::arg_error "" [punk::args::get_spec $id] {*}$opts -aserror 0 -parsedargs $parseresult] + # #return [uplevel 1 [list punk::args::usage {*}$opts $id]] + # } + # } + # #puts "--->origin $specid queryargs: $specargs" + # set origin $specid + # set queryargs $specargs + # } + + # if {[string match "(autodef)*" $origin]} { + # #wasn't resolved by id - so take this as a request to generate it (probably there is an existing custom def - and this has been manually requested to get the default) + # set origin [string range $origin [string length (autodef)] end] + # set resolved $origin + # } + + # set autoid "" + # switch -- $cmdtype { + # object { + # #class is also an object + # #todo -mixins etc etc + # set class [info object class $origin] + # #the call: info object methods -all + # # seems to do the right thing as far as hiding unexported methods, and showing things like destroy + # # - which don't seem to be otherwise easily introspectable + # set public_methods [info object methods $origin -all] + # #set class_methods [info class methods $class] + # #set object_methods [info object methods $origin] + + # if {[llength $queryargs]} { + # set c1 [lindex $queryargs 0] + # if {$c1 in $public_methods} { + # switch -- $c1 { + # new { + # set constructorinfo [info class constructor $origin] + # set arglist [lindex $constructorinfo 0] + # set argdef [punk::lib::tstr -return string { + # @id -id "(autodef)${$origin} new" + # @cmd -name "${$origin} new"\ + # -summary\ + # "Create new object instance."\ + # -help\ + # "create object with autogenerated command name. + # Arguments are passed to the constructor." + # @values + # }] + # set i 0 + # foreach a $arglist { + # if {[llength $a] == 1} { + # if {$i == [llength $arglist]-1 && $a eq "args"} { + # #'args' is only special if last + # append argdef \n "args -optional 1 -multiple 1" + # } else { + # append argdef \n "$a" + # } + # } else { + # append argdef \n "[lindex $a 0] -default [lindex $a 1]" + # } + # incr i + # } + # punk::args::define $argdef + # set queryargs_remaining [lrange $queryargs 1 end] + # switch -- [dict get $opts -return] { + # string { + # set estyle "basic" + # } + # tableobject { + # set estyle "minimal" + # } + # default { + # set estyle "standard" + # } + # } + # if {[catch {punk::args::parse $queryargs_remaining -form [dict get $opts -form] -errorstyle $estyle withid "(autodef)$origin new"} parseresult]} { + # if {[dict get $opts -return] eq "tableobject"} { + # return [punk::args::arg_error "$parseresult" [punk::args::get_spec "(autodef)$origin new"] {*}$opts -aserror 0] + # } else { + # return $parseresult + # } + # } else { + # if {!$scheme_received} { + # dict set opts -scheme info + # } + # return [punk::args::arg_error "" [punk::args::get_spec "(autodef)$origin new"] {*}$opts -aserror 0 -parsedargs $parseresult] + # #return [punk::args::usage {*}$opts "(autodef)$origin new"] + # } + # } + # create { + # set constructorinfo [info class constructor $origin] + # set arglist [lindex $constructorinfo 0] + # set argdef [punk::lib::tstr -return string { + # @id -id "(autodef)${$origin} create" + # @cmd -name "${$origin} create"\ + # -summary\ + # "Create new object instance with specified command name."\ + # -help\ + # "create object with specified command name. + # Arguments following objectName are passed to the constructor." + # @values -min 1 + # objectName -type string -help\ + # "possibly namespaced name for object instance command" + # }] + # set i 0 + # foreach a $arglist { + # if {[llength $a] == 1} { + # if {$i == [llength $arglist]-1 && $a eq "args"} { + # #'args' is only special if last + # append argdef \n "args -optional 1 -multiple 1" + # } else { + # append argdef \n "$a" + # } + # } else { + # append argdef \n "[lindex $a 0] -default [lindex $a 1]" + # } + # incr i + # } + # punk::args::define $argdef + # set queryargs_remaining [lrange $queryargs 1 end] + # switch -- [dict get $opts -return] { + # string { + # set estyle "basic" + # } + # tableobject { + # set estyle "minimal" + # } + # default { + # set estyle "standard" + # } + # } + # if {[catch {punk::args::parse $queryargs_remaining -form [dict get $opts -form] -errorstyle $estyle withid "(autodef)$origin create"} parseresult]} { + # if {[dict get $opts -return] eq "tableobject"} { + # return [punk::args::arg_error "$parseresult" [punk::args::get_spec "(autodef)$origin create"] {*}$opts -aserror 0] + # } else { + # return $parseresult + # } + # } else { + # if {!$scheme_received} { + # dict set opts -scheme info + # } + # return [punk::args::arg_error "" [punk::args::get_spec "(autodef)$origin create"] {*}$opts -aserror 0 -parsedargs $parseresult] + # #return [punk::args::usage {*}$opts "(autodef)$origin create"] + # } + # } + # destroy { + # #review - generally no doc + # # but we may want notes about a specific destructor + # set argdef [punk::lib::tstr -return string { + # @id -id "(autodef)${$origin} destroy" + # @cmd -name "destroy"\ + # -summary\ + # "delete object instance."\ + # -help\ + # "delete object, calling destructor if any. + # destroy accepts no arguments." + # @values -min 0 -max 0 + # }] + # punk::args::define $argdef + # set queryargs_remaining [lrange $queryargs 1 end] + # switch -- [dict get $opts -return] { + # string { + # set estyle "basic" + # } + # tableobject { + # set estyle "minimal" + # } + # default { + # set estyle "standard" + # } + # } + # if {[catch {punk::args::parse $queryargs_remaining -form [dict get $opts -form] -errorstyle $estyle withid "(autodef)$origin destroy"} parseresult]} { + # if {[dict get $opts -return] eq "tableobject"} { + # return [punk::args::arg_error "$parseresult" [punk::args::get_spec "(autodef)$origin destroy"] {*}$opts -aserror 0] + # } else { + # return $parseresult + # } + # } else { + # if {!$scheme_received} { + # dict set opts -scheme info + # } + # return [punk::args::arg_error "" [punk::args::get_spec "(autodef)$origin destroy"] {*}$opts -aserror 0 -parsedargs $parseresult] + # #return [punk::args::usage {*}$opts "(autodef)$origin destroy"] + # } + # } + # default { + # #use info object call to resolve callchain + # #we assume the first impl is the topmost in the callchain + # # and its call signature is therefore the one we are interested in - REVIEW + # # we should probably ignore generaltypes filter|unknown and look for a subsequent method|private? + # set implementations [::info object call $origin $c1] + # #result documented as list of 4 element lists + # #set callinfo [lindex $implementations 0] + # set oodef "" + # foreach impl $implementations { + # lassign $impl generaltype mname location methodtype + # switch -- $generaltype { + # method - private { + # #objects being dynamic systems - we should always reinspect. + # #Don't use the cached (autodef) def + # #If there is a custom def override - use it (should really be -dynamic - but we don't check) + # if {$location eq "object"} { + # set idcustom "$origin $c1" + # #set id "[string trimleft $origin :] $c1" ;# " " + # if {[info commands ::punk::args::id_exists] ne ""} { + # if {[punk::args::id_exists $idcustom]} { + # return [uplevel 1 [list punk::args::usage {*}$opts $idcustom]] + # } + # } + # set oodef [::info object definition $origin $c1] + # } else { + # #set id "[string trimleft $location :] $c1" ;# " " + # set idcustom "$location $c1" + # if {[info commands ::punk::args::id_exists] ne ""} { + # if {[punk::args::id_exists $idcustom]} { + # return [uplevel 1 [list punk::args::usage {*}$opts $idcustom]] + # } + # } + # set oodef [::info class definition $location $c1] + # } + # break + # } + # filter { + # } + # unknown { + # } + # } + # } + # if {$oodef ne ""} { + # set autoid "(autodef)$location $c1" + # set arglist [lindex $oodef 0] + # set argdef [punk::lib::tstr -return string { + # @id -id "${$autoid}" + # @cmd -name "${$location} ${$c1}" -help\ + # "(autogenerated by arginfo) + # arglist:${$arglist}" + # @values + # }] + # set i 0 + # #for 9.1+ can use -integer + # foreach a $arglist { + # switch -- [llength $a] { + # 1 { + # if {$i == [llength $arglist]-1 && $a eq "args"} { + # #'args' is only special if last + # append argdef \n "args -optional 1 -multiple 1" + # } else { + # append argdef \n "$a" + # } + # } + # 2 { + # append argdef \n "[lindex $a 0] -default {[lindex $a 1]} -optional 1" + # } + # default { + # error "punk::ns::arginfo unexpected oo argument signature '$arglist'\noodef:$oodef\nimplementations:$implementations" + # } + # } + # incr i + # } + # punk::args::define $argdef + # return [punk::args::usage {*}$opts $autoid] + # } else { + # return "unable to resolve $origin method $c1" + # } + + # } + # } + # } + # } + # set choicelabeldict [dict create] + # set choiceinfodict [dict create] + # foreach cmd $public_methods { + # switch -- $cmd { + # new - create - destroy { + # #todo + # } + # default { + # set implementations [::info object call $origin $cmd] + # set def "" + # foreach impl $implementations { + # lassign $impl generaltype mname location methodtype + # switch -- $generaltype { + # method - private { + # if {$location eq "object" || $location eq $origin} { + # #set id "[string trimleft $origin :] $cmd" ;# " " + # set id "$origin $cmd" + # dict set choiceinfodict $cmd {{doctype objectmethod}} + # } elseif {$location eq $class} { + # set id "$class $cmd" + # dict set choiceinfodict $cmd {{doctype classmethod}} + # } else { + # #set id "[string trimleft $location :] $cmd" ;# " " + # set id "$location $cmd" + # if {[string match "core method:*" $methodtype]} { + # dict lappend choiceinfodict $cmd {doctype coremethod} + # } else { + # dict lappend choiceinfodict $cmd [list doctype [list $location $methodtype]] + # } + # } + # if {[punk::args::id_exists $id]} { + # #dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]" + # dict lappend choiceinfodict $cmd {doctype punkargs} + # dict lappend choiceinfodict $cmd [list subhelp {*}$id] + # } + # break + # } + # filter { + # } + # unknown { + # dict set choiceinfodict $cmd {{doctype unknown}} + # } + # } + # } + # } + # } + # } + + # set vline [list method -choices $public_methods -choicelabels $choicelabeldict -choiceinfo $choiceinfodict -choiceprefix 0] ;#methods must be specified in full always? - review + # #puts stderr "--->$vline" + # set autoid "(autodef)$origin" + # set argdef [punk::lib::tstr -return string { + # @id -id ${$autoid} + # @cmd -name "Object: ${$origin}" -help\ + # "Instance of class: ${$class} (info autogenerated)" + # @leaders -min 1 + # }] + # append argdef \n $vline + # punk::args::define $argdef + + # } + # privateObject { + # return "Command is a privateObject - no info currently available" + # } + # privateClass { + # return "Command is a privateClass - no info currently available" + # } + # interp { + # #todo + # } + # script { + # #todo + # } + # ensemble { + # #review + # #todo - check -unknown + # #if there is a -unknown handler - we can't be sure the choices in -map or from -namespace are exhaustive. + # #presumably -choiceprefix should be zero in that case?? + + # set ensembleinfo [namespace ensemble configure $origin] + # set parameters [dict get $ensembleinfo -parameters] + # set prefixes [dict get $ensembleinfo -prefixes] + # set map [dict get $ensembleinfo -map] + # set ns [dict get $ensembleinfo -namespace] + + # #review - we can have a combination of commands from -map as well as those exported from -namespace + # # if and only if -subcommands is specified + + # set subcommand_dict [dict create] + # set commands [list] + # set nscommands [list] + # if {[llength [dict get $ensembleinfo -subcommands]]} { + # #set exportspecs [namespace eval $ns {namespace export}] + # #foreach pat $exportspecs { + # # lappend nscommands {*}[info commands ${ns}::$pat] + # #} + # #when using -subcommands, even unexported commands are available + # set nscommands [info commands ${ns}::*] + # foreach sub [dict get $ensembleinfo -subcommands] { + # if {[dict exists $map $sub]} { + # #-map takes precence over same name exported from -namespace + # dict set subcommand_dict $sub [dict get $map $sub] + # } elseif {"${ns}::$sub" in $nscommands} { + # dict set subcommand_dict $sub ${ns}::$sub + # } else { + # #subcommand probably supplied via -unknown handler? + # dict set subcommand_dict $sub "" + # } + # } + # } else { + # if {[dict size $map]} { + # set subcommand_dict $map + # } else { + # set exportspecs [namespace eval $ns {namespace export}] + # foreach pat $exportspecs { + # lappend nscommands {*}[info commands ${ns}::$pat] + # } + # foreach fqc $nscommands { + # dict set subcommand_dict [namespace tail $fqc] $fqc + # } + # } + # } + + + # set subcommands [lsort [dict keys $subcommand_dict]] + # if {[llength $queryargs]} { + # set posn_subcommand [llength $parameters];#ensemble may have '-parameters' list specified - parameters that come before the subcommand + # if {$posn_subcommand > 0} { + # set params [lrange $queryargs 0 $posn_subcommand-1] + # set remaining_queryargs [lrange $queryargs $posn_subcommand end] + # } else { + # set params [list] + # set remaining_queryargs $queryargs + # } + # if {[llength $remaining_queryargs]} { + # if {$prefixes} { + # set match [tcl::prefix::match -error {} $subcommands [lindex $remaining_queryargs 0]] + # } else { + # set match [lindex $remaining_queryargs 0] + # } + # if {$match in $subcommands} { + # set subcmd [dict get $subcommand_dict $match] + # #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + # if {!$scheme_received} { + # dict unset opts -scheme + # } + # #return [arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] + # #use tailcall so %caller% is reported properly in error msg + # tailcall arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + # } + # } + # } + + # #todo - synopsis? + # set choicelabeldict [dict create] + + # set choiceinfodict [dict create] + + # dict for {sub subwhat} $subcommand_dict { + # if {[llength $subwhat] > 1} { + # #TODO - resolve using cmdinfo? + # puts stderr "arginfo warning: subcommand $sub points to multiword target $subwhat - TODO" + # } + # set targetfirstword [lindex $subwhat 0] + # set targetinfo [cmdwhich $targetfirstword] + # set targetorigin [dict get $targetinfo origin] + # set targetcmdtype [dict get $targetinfo origintype] + # set nstarget [nsprefix $targetorigin] + + # dict lappend choiceinfodict $sub [list doctype $targetcmdtype] + + # if {[punk::args::id_exists [list $origin $sub]]} { + # dict lappend choiceinfodict $sub {doctype punkargs} + # dict lappend choiceinfodict $sub [list subhelp {*}$origin $sub] + # } elseif {[punk::args::id_exists $targetorigin]} { + # dict lappend choiceinfodict $sub {doctype punkargs} + # dict lappend choiceinfodict $sub [list subhelp {*}$targetorigin] + # } else { + # #puts stderr "arginfo ensemble--- NO doc for [list $origin $sub] or $origin" + # } + + # } + + # set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict -choiceinfo $choiceinfodict] + # set autoid "(autodef)$origin" + # puts "ENSEMBLE auto def $autoid (arginfo)" + # set argdef [punk::lib::tstr -return string { + # @id -id ${$autoid} + # @cmd -help\ + # "(autogenerated by arginfo) + # ensemble: ${$origin}" + # }] + # if {[llength $parameters] == 0} { + # append argdef \n "@leaders -min 1" + # } else { + # append argdef \n "@leaders -min [expr {[llength $parameters]+1}]" + # foreach p $parameters { + # append argdef \n "$p -type string -help { (leading ensemble parameter)}" + # } + # } + # append argdef \n "@values -unnamed true" + # append argdef \n $vline + # punk::args::define $argdef + # } + # } + + # #if {$autoid ne ""} { + # # return [punk::args::usage {*}$opts $autoid] + # #} + + + # #check ensemble before testing punk::arg::id_exists + # #we want to recalculate ensemble usage info in case ensemble has been modified + + # if {$autoid ne ""} { + # switch -- [dict get $opts -return] { + # string { + # set estyle "basic" + # } + # tableobject { + # set estyle "minimal" + # } + # default { + # set estyle "standard" + # } + # } + # if {[catch {punk::args::parse $queryargs -form [dict get $opts -form] -errorstyle $estyle withid $autoid} parseresult]} { + # # parsing error e.g Bad number of leading values + # #override -scheme in opts with -scheme error + # if {[dict get $opts -return] eq "tableobject"} { + # return [punk::args::arg_error "$parseresult" [punk::args::get_spec $autoid] {*}$opts -aserror 0] + # } else { + # return $parseresult + # } + # } else { + # #show usage - with goodargs marked + # #return [punk::args::arg_error "" [punk::args::get_spec $autoid] -scheme info -aserror 0 {*}$opts -parsedargs $parseresult] + # if {!$scheme_received} { + # dict set opts -scheme info + # } + # return [punk::args::arg_error "" [punk::args::get_spec $autoid] {*}$opts -aserror 0 -parsedargs $parseresult] + # } + # #return [punk::args::usage {*}$opts $autoid] + # } + + # #check for tepam help + # if {[info exists ::tepam::ProcedureList]} { + # if {$origin in $::tepam::ProcedureList} { + # return [tepam::ProcedureHelp $origin 1] ;#use 1 to return rather than emit to stdout + # } else { + # #handle any tepam functions that don't eat their own dogfood but have help variables + # #e.g tepam::procedure, tepam::argument_dialogbox + # #Rather than hardcode these - we'll guess that any added will use the same scheme.. + # if {[namespace qualifiers $origin] eq "::tepam"} { + # set func [namespace tail $origin] + # #tepam XXXHelp vars don't exactly match procedure names :/ + # if {[info exists ::tepam::${func}Help]} { + # return [set ::tepam::${func}Help] + # } else { + # set f2 [string totitle $func] + # if {[info exists ::tepam::${f2}Help]} { + # return [set ::tepam::${f2}Help] + # } + # #e.g argument_dialogbox -> ArgumentDialogboxHelp + # set parts [split $func _] + # set uparts [lmap p $parts {string totitle $p}] + # set f3 [join [list {*}$uparts Help] ""] + # if {[info exists ::tepam::${f3}]} { + # return [set ::tepam::${f3}] + # } + # } + # } + # } + # } + + # set origin_ns [nsprefix $origin] + # set parts [nsparts_cached $origin_ns] + # set weird_ns 0 + # if {[lsearch $parts :*] >=0} { + # set weird_ns 1 + # } + # if {$weird_ns} { + # set argl {} + # set tail [nstail $origin] + # set cmdtype [nseval_ifexists $origin_ns [list punk::ns::cmdtype $tail]] + # if {$cmdtype eq "proc"} { + # foreach a [nseval_ifexists $origin_ns [list info args $tail]] { + # if {[nseval_ifexists $origin_ns [list info default $tail $a def]]} { + # lappend a $def + # } + # lappend argl $a + # } + # } + # } else { + # set cmdtype [punk::ns::cmdtype $origin] + # if {$cmdtype eq "proc"} { + # set argl {} + # set infoargs [info args $origin] + # foreach a $infoargs { + # if {[info default $origin $a def]} { + # lappend a $def + # } + # lappend argl $a + # } + # } + # } + + # if {[llength $queryargs]} { + # #todo - something better ? + # switch -- [dict get $opts -return] { + # string { + # set estyle "basic" + # } + # tableobject { + # set estyle "minimal" + # } + # default { + # set estyle "standard" + # } + # } + + # if {[punk::args::id_exists $origin]} { + # if {[catch {punk::args::parse $queryargs -form [dict get $opts -form] -errorstyle $estyle withid $origin} parseresult]} { + # if {[dict get $opts -return] eq "tableobject"} { + # return [punk::args::arg_error "$parseresult" [punk::args::get_spec $origin] {*}$opts -aserror 0] + # } else { + # return $parseresult + # } + # } else { + # #show usage - with goodargs marked + # if {!$scheme_received} { + # dict set opts -scheme info + # } + # return [punk::args::arg_error "" [punk::args::get_spec $origin] {*}$opts -aserror 0 -parsedargs $parseresult] + # } + # } + # set msg "Undocumented or nonexistant command $origin $queryargs" + # append msg \n "$origin Type: $cmdtype" + # } else { + # if {$cmdtype eq "proc"} { + # set msg "Undocumented proc $origin" + # append msg \n "No argument processor detected" + # append msg \n "function signature: $resolved $argl" + # } else { + # set msg "Undocumented command $origin. Type: $cmdtype" + # } + # } + # if {[llength $grepstr] != 0} { + # if {[llength $grepstr] == 1} { + # return [punk::grepstr -no-linenumbers -highlight red [lindex $grepstr 0] $msg] + # } else { + # return [punk::grepstr -no-linenumbers -highlight [lrange $grepstr 1 end] [lindex $grepstr 0] $msg] + # } + # } + # return $msg + #} - Note that native commands commands not explicitly documented will - generally produce no useful info. For example sqlite3 dbcmd objects - could theoretically be documented - but as 'info cmdtype' just shows - 'native' they can't (?) be identified as belonging to sqlite3 without - calling them. arginfo deliberately avoids calling commands to elicit - usage information as this is inherently risky. (could create a file, - exit the interp etc) - " - -return -type string -default table -choices {string table tableobject} + #todo - package up as navns + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::ns::corp + @cmd -name punk::ns::corp\ + -summary\ + "Show alias info or proc body/args"\ + -help\ + "Show alias or proc information. + 'corp' (being the reverse spelling of proc) + will display the Tcl 'proc name args body' statement + for the proc. + Essentially this is a convenient way to display the + proc body including argument info, instead of + separately calling 'info args ' 'info body ' + etc. + The body may display with an additional + comment inserted to display information such as the + namespace origin. Such a comment begins with #corp#. + + Returns a list: proc + (as long as any syntax highlighter is written to + avoid breaking the structure. e.g by avoiding the + insertion of ANSI between an escaping backslash and + its target character) + If the output is to be used as a script to regenerate a + procedure, '-syntax none' should be used to avoid ANSI + colours, or the resulting arglist and body should be + run through 'ansistrip'. + " + @opts + #todo - make definition @dynamic - load highlighters as functions? + -syntax -type string -typesynopsis "none|basic" -default basic -choices {none basic}\ + -choicelabels { + none\ + " Plain text output" + basic\ + " Comment and bracket highlights. + This is a basic colourizer - not + a full Tcl syntax highlighter." + }\ + -help\ + "Type of syntax highlighting on result. + Note that -syntax none will always return a proper Tcl + List: proc + - but a syntax highlighter may return a string that + is not a Tcl list. + The 'basic' highlighter " + @values -min 1 -max -1 + commandname -type string -typesynopsis ${$I}procname${$NI}|${$I}alias${$NI} -help\ + "May be either the fully qualified path for the command, + or a relative name that is resolvable from the current + namespace." + }] + } + proc corp {args} { + set argd [punk::args::parse $args withid ::punk::ns::corp] + set path [dict get $argd values commandname] + set syntax [dict get $argd opts -syntax] + #thanks to Richard Suchenwirth for the original - wiki.tcl-lang.org/page/corp + #Note: modified here to support aliases and relative/absolute name (with respect to namespace .ie ::name vs name) + if {[info exists punk::console::tabwidth]} { + set tw $::punk::console::tabwidth + } else { + set tw 8 + } + set indent [string repeat " " $tw] ;#match + #set indent [string repeat " " $tw] ;#A more sensible default for code - review + if {[info exists ::auto_index($path)]} { + set body "\n${indent}#corp# auto_index $::auto_index($path)" + } else { + set body "" + } - } {${[punk::args::resolved_def -types opts ::punk::args::arg_error -scheme]}} { - -form -default 0 -help\ - "Ordinal index or name of command form" - -grepstr -default "" -type list -typesynopsis regex -help\ - "list consisting of regex, optionally followed by ANSI names for highlighting - (incomplete - todo)" - -- -type none -help\ - "End of options marker - Use this if the command to view begins with a -" - @values -min 1 - commandpath -help\ - "command (may be alias, ensemble, tcl::oo object, tepam proc etc)" - subcommand -optional 1 -multiple 1 -default {} -help\ - "subcommand if commandpath is an ensemble. - Multiple subcommands can be supplied if ensembles are further nested" - } - proc arginfo {args} { - lassign [dict values [punk::args::parse $args withid ::punk::ns::arginfo]] leaders opts values received - set nscaller [uplevel 1 [list ::namespace current]] - #review - setting this afterwards is an architecture smell - we should be able to override the default in the dynamic part - #todo - enable retrieving by id just the record_opts part - so we can treat as a dict directly, as well as easily apply it as a different flag name. - if {![dict exists $received -scheme]} { - #dict set opts -scheme info - set scheme_received 0 + #we want to handle edge cases of commands such as "" or :x + #various builtins such as 'namespace which' won't work + if {[string match ::* $path]} { + set targetns [nsprefix $path] + set name [nstail $path] } else { - set scheme_received 1; #so we know not to override caller's explicit choice + set thispath [uplevel 1 [list ::nsthis $path]] + set targetns [nsprefix $thispath] + set name [nstail $thispath] } + #puts stderr "corp upns:$upns" - set querycommand [dict get $values commandpath] - set queryargs [dict get $values subcommand] - set grepstr [dict get $opts -grepstr] - set opts [dict remove $opts -grepstr] - #puts stdout "---------------------arginfo: '$args' querycommand:'$querycommand' queryargs:'$queryargs'" + #set name [string trim $name :] + #set origin [namespace origin ${upns}::$name] + set origin [nseval $targetns [list ::namespace origin $name]] + set resolved [nseval $targetns [list ::namespace which $name]] - #todo - similar to corp? review corp resolution process - #should handle lazy loaded commands (via ::auto_index) that are not yet present but may be documented + #A renamed alias may exist that is the same name as a proc that was created later.. so we must check for the proc before looking into aliases! + #set iproc [info procs $origin] ;#This will find empty-string command as ::ns:: but miss finding proc ":x" as ::ns:::x + set iproc [nsjoin $targetns [nseval $targetns [list ::info procs $name]]] + if {$origin ni $iproc} { - set cinfo [uplevel 1 [list cmdwhich $querycommand]] - set origin [dict get $cinfo origin] - set resolved [dict get $cinfo which] - set cmdtype [dict get $cinfo origintype] - switch -- $cmdtype { - script { - #assumed to be an 'alias' script - ie proper list - not an arbitrary tcl code block - set scriptargs [lrange $origin 1 end] ;#arguments that were curried into the alias script - set origin [lindex $origin 0] - set queryargs [list {*}$scriptargs {*}$queryargs] - return [uplevel 1 [list punk::ns::arginfo {*}$opts $origin {*}$queryargs]] - } - alias { - #alias to an alias - return [uplevel 1 [list punk::ns::arginfo {*}$opts $origin {*}$queryargs]] - } - } + #It seems an interp alias of "::x"" behaves the same as "x" + #But we can't create both at the same time - and they have to be queried by the exact name. + #So we query for alias with and without leading :: + set alias_qualified [interp alias {} [string trim $origin :]] + set alias_unqualified [interp alias {} $origin] + if {[string length $alias_qualified] && [string length $alias_unqualified]} { + #our assumptions are wrong.. change in tcl version? + puts stderr "corp: Found alias for unqualified name:'[string trim $origin :]' and qualified name: '$origin' - unexpected (assumed impossible as at Tcl 8.6)" + if {$alias_qualified ne $alias_unqalified} { - #JJJ - #check for a direct match first - if {![llength $queryargs]} { - #puts stderr "---->arginfo '$args' update_definitions [list [namespace qualifiers $origin]]" - punk::args::update_definitions [list [namespace qualifiers $origin]] ;#update_definitions will treat empty string as global ns :: - if {![punk::args::id_exists $origin] && ![punk::args::id_exists (autodef)$origin]} { - uplevel 1 [list punk::ns::generate_autodef $origin] + } else { + set alias $alias_unqualified + } + } else { + set alias ${alias_qualified}${alias_unqualified} ;#concatenate - as at least one should be empty } - if {[punk::args::id_exists (autodef)$origin]} { - set origin (autodef)$origin + if {[string length $alias]} { + #todo - consider following alias-chain to ultimate proc? + #it can always be manually done with: + #.= corp $name |/1> corp |/1> corp .. + #depending on number of aliases in the chain + return [list alias {*}$alias] } - if {[punk::args::id_exists $origin]} { - switch -- [dict get $opts -return] { - string { - set estyle "basic" - } - tableobject { - set estyle "minimal" - } - default { - set estyle "standard" - } - } - if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid $origin} parseresult]} { - if {[dict get $opts -return] eq "tableobject"} { - return [punk::args::arg_error "$parseresult" [punk::args::get_spec $origin] {*}$opts -aserror 0] - } else { - return $parseresult - } + } + if {[nsprefix $origin] ne [nsprefix [nsjoin ${targetns} $name]]} { + append body \n "${indent}#corp# namespace origin $origin" + } + + if {$body ne "" && [string index $body end] ne "\n"} { + append body \n + } + if {![catch {package require textutil::tabify} errpkg]} { + #set bodytext [info body $origin] + set bodytext [nseval $targetns [list ::info body $name]] + #punk::lib::indent preserves trailing empty lines - unlike textutil version + set bodytext [punk::lib::undent [textutil::untabify2 $bodytext $tw]] + append body [punk::lib::indent $bodytext $indent] + } else { + #append body [info body $origin] + #relevant test test::punk::ns SUITE ns corp.test corp_leadingcolon_functionname + append body [nseval $targetns [list ::info body $name]] + } + set argl {} + set argnames [nseval $targetns [list ::info args $name]] + foreach a $argnames { + #if {[info default $origin $a defvar]} { + # lappend a $defvar + #} + set result [nseval $targetns [string map [list %n% $name %a% $a] { + #qualify all command names when running in arbitrary namespace + ::if {[::info default "%n%" "%a%" punk_ns_corp_defvar]} { + ::return [::list default $punk_ns_corp_defvar][::unset punk_ns_corp_defvar] ;#keep the targetns tidy } else { - if {!$scheme_received} { - dict set opts -scheme info - } - return [punk::args::arg_error "" [punk::args::get_spec $origin] {*}$opts -aserror 0 -parsedargs $parseresult] + ::return [::list none] } + }]] + if {[lindex $result 0] eq "default"} { + lappend a [lindex $result 1] + } + lappend argl $a + } + #list proc [nsjoin ${targetns} $name] $argl $body + #todo - load highlighters as functions from somewhere + switch -- $syntax { + basic { + #rudimentary colourising only + set argl [punk::grepstr -return all -highlight tk-darkcyan {\{|\}} $argl] + set body [punk::grepstr -return all -highlight green {^\s*#.*} $body] ;#Note, will not highlight comments at end of line - like this one. + set body [punk::grepstr -return all -highlight green {;\s*(#.*)} $body] ;#treat as tail comment only if preceeded by semicolon + #set body [punk::grepstr -return all -highlight tk-darkcyan {\{|\}} $body] + set body [punk::grepstr -return all -highlight tk-darkcyan {^(\{)|[^\\](\{+)} $body] + set body [punk::grepstr -return all -highlight tk-darkcyan {[^\\](\}+)} $body] + set body [punk::grepstr -return all -highlight tk-orange {\[|\]} $body] + #ansi colourised items in list format may not always have desired string representation (list escaping can occur) + #return as a string - which may not be a proper Tcl list! + return "proc $resolved {$argl} {\n$body\n}" } } + list proc $resolved $argl $body + } + + + #review ??? + proc ns_relative_to_location {name} { + if {[string match ::* $name]} { + error "ns_relative_to_location accepts a relative namespace name only ie one without leading ::" + } + } + proc ns_absolute_to_location {name} { - set id $origin - #puts stderr "____>arginfo '$args' update_definitions [list [namespace qualifiers $id]]" - punk::args::update_definitions [list [namespace qualifiers $id]] + } - #check longest first checking for id matching ::cmd ?subcmd..? - #REVIEW - this doesn't cater for prefix callable subcommands - if {[llength $queryargs]} { - if {[punk::args::id_exists [list $id {*}$queryargs]]} { - switch -- [dict get $opts -return] { - string { - set estyle "basic" - } - tableobject { - set estyle "minimal" - } - default { - set estyle "standard" + tcl::namespace::eval internal { + + + #maintenance: similar in punk::winrun + proc get_run_opts {options alias_dict arglist} { + if {[catch { + set callerinfo [info level -1] + } errM]} { + set caller "" + } else { + set caller [lindex $callerinfo 0] + } + + #update alias dict mapping shortnames to longnames - longnames to self + foreach o $options { + dict set alias_dict $o $o + } + set known_runopts [dict keys $alias_dict] + set runopts [list] + set cmdargs [list] + + set first_eopt_posn [lsearch $arglist --] + if {$first_eopt_posn >=0} { + set pre_eopts [lrange $arglist 0 $first_eopt_posn-1] + set is_eopt_for_runopts 1 ;#default assumption that it is for this function rather than part of user's commandline - cycle through previous args to disprove. + foreach pre $pre_eopts { + if {$pre ni $known_runopts} { + set is_eopt_for_runopts 0; #the first -- isn't for us. } } - if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid [list $id {*}$queryargs]} parseresult]} { - if {[dict get $opts -return] eq "tableobject"} { - return [punk::args::arg_error "$parseresult" [punk::args::get_spec [list $id {*}$queryargs]] {*}$opts -aserror 0] - } else { - return $parseresult - } - } else { - if {!$scheme_received} { - dict set opts -scheme info - } - return [punk::args::arg_error "" [punk::args::get_spec [list $id {*}$queryargs]] {*}$opts -aserror 0 -parsedargs $parseresult] - #return [uplevel 1 [list punk::args::usage {*}$opts [list $id {*}$queryargs]]] + } else { + set is_eopt_for_runopts 0 + } + #split on first -- if only known opts preceding (or nothing preceeding) - otherwise split on first arg that doesn't look like an option and bomb if unrecognised flags before it. + if {$is_eopt_for_runopts} { + set idx_first_cmdarg [expr $first_eopt_posn + 1] + set runopts [lrange $arglist 0 $idx_first_cmdarg-2] ;#exclude -- from runopts - it's just a separator. + } else { + set idx_first_cmdarg [lsearch -not $arglist "-*"] + set runopts [lrange $arglist 0 $idx_first_cmdarg-1] + } + set cmdargs [lrange $arglist $idx_first_cmdarg end] + foreach o $runopts { + if {$o ni $known_runopts} { + error "$caller: Unknown runoption $o - known options $known_runopts" } } + set runopts [lmap o $runopts {dict get $alias_dict $o}] + #todo - get these out of here. Should be supplied by caller. + if {"-allowvars" in $runopts && "-disallowvars" in $runopts} { + puts stderr "Warning - conflicting options -allowvars & -disallowvars specified: $arglist" + } + + #maintain order: runopts $runopts cmdargs $cmdargs as first 4 args (don't break 'lassign [get_runopts $args] _ runopts _ cmdargs') + #todo - add new keys after these indicating type of commandline etc. + return [list runopts $runopts cmdargs $cmdargs] } - #didn't find any exact matches - #traverse from other direction taking prefixes into account - set specid "" - if {[punk::args::id_exists $id]} { - set specid $id - } elseif {[punk::args::id_exists (autodef)$id]} { - set specid (autodef)$id - } - - if {$specid ne "" && [punk::args::id_exists $specid]} { - #cycle forward through leading values - set specargs $queryargs - if {[llength $queryargs]} { - #jjj - set spec [punk::args::get_spec $specid] - #--------------------------------------------------------------------------- - set form_names [dict get $spec form_names] - if {[llength $form_names] == 1} { - set fid [lindex $form_names 0] - } else { - #review - -form only applies to final command? - # -form must be a list if we have multiple levels of multi-form commands? - set opt_form [dict get $opts -form] - if {[string is integer -strict $opt_form]} { - if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { - error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - } - set fid [lindex $form_names $opt_form] - } else { - if {$opt_form ni $form_names} { - error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - } - set fid $opt_form - } - } - #--------------------------------------------------------------------------- - set nextqueryargs [list] ;#build a list of prefix-resolved queryargs - set queryargs_untested $queryargs - foreach q $queryargs { - if {[llength [dict get $spec FORMS $fid LEADER_NAMES]]} { - #todo: fix - set subitems [dict get $spec FORMS $fid LEADER_NAMES] - if {[llength $subitems]} { - set next [lindex $subitems 0] - set arginfo [dict get $spec FORMS $fid ARG_INFO $next] - - set allchoices [list] - set choices [punk::args::system::Dict_getdef $arginfo -choices {}] - set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}] - #maintenance smell - similar/dup of some punk::args logic - review - #-choiceprefixdenylist ?? - set choiceprefixreservelist [punk::args::system::Dict_getdef $arginfo -choiceprefixreservelist {}] - if {[dict exists $choicegroups ""]} { - dict lappend choicegroups "" {*}$choices - } else { - set choicegroups [dict merge [dict create "" $choices] $choicegroups] - } - dict for {groupname clist} $choicegroups { - lappend allchoices {*}$clist - } - set resolved_q [tcl::prefix::match -error "" [list {*}$allchoices {*}$choiceprefixreservelist] $q] - if {$resolved_q eq "" || $resolved_q in $choiceprefixreservelist} { - break - } - lappend nextqueryargs $resolved_q - lpop queryargs_untested 0 - #ledit queryargs_untested 0 0 - if {$resolved_q ne $q} { - #we have our first difference - recurse with new query args - #set numvals [expr {[llength $queryargs]+1}] - #return [ punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$nextqueryargs {*}$queryargs_untested] - #puts "===> testing arginfo {*}$opts $querycommand {*}$nextqueryargs {*}$queryargs_untested" - if {!$scheme_received} { - dict unset opts -scheme - } - return [ punk::ns::arginfo {*}$opts {*}$specid {*}$nextqueryargs {*}$queryargs_untested] - - } - #check if subcommands so far have a custom args def - #set currentid [list $querycommand {*}$nextqueryargs] - set currentid [list {*}$specid {*}$nextqueryargs] - if {[punk::args::id_exists $currentid]} { - set spec [punk::args::get_spec $currentid] - #--------------------------------------------------------------------------- - set form_names [dict get $spec form_names] - if {[llength $form_names] == 1} { - set fid [lindex $form_names 0] - } else { - #review - -form only applies to final command? - # -form must be a list if we have multiple levels of multi-form commands? - set opt_form [dict get $opts -form] - if {[string is integer -strict $opt_form]} { - if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { - error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - } - set fid [lindex $form_names $opt_form] - } else { - if {$opt_form ni $form_names} { - error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - } - set fid $opt_form - } - } - #--------------------------------------------------------------------------- - set specid $currentid - set specargs $queryargs_untested - set nextqueryargs [list] - } else { - #We can get no further with custom defs - #It is possible we have a documented lower level subcommand but missing the intermediate - #e.g if ::trace remove command was specified and is documented - it will be found above - #but if ::trace remove is not documented and the query is "::trace remove com" - #There is no way to determine com is a prefix as we don't have the intermediate documented -choice info available. - #that's probably ok. - break - } - } - } else { - #review - break - } - } - } else { - switch -- [dict get $opts -return] { - string { - set estyle "basic" - } - tableobject { - set estyle "minimal" - } - default { - set estyle "standard" - } - } - if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid $id} parseresult]} { - if {[dict get $opts -return] eq "tableobject"} { - return [punk::args::arg_error "$parseresult" [punk::args::get_spec $id] {*}$opts -aserror 0] - } else { - return $parseresult - } - } else { - if {!$scheme_received} { - dict set opts -scheme info - } - return [punk::args::arg_error "" [punk::args::get_spec $id] {*}$opts -aserror 0 -parsedargs $parseresult] - #return [uplevel 1 [list punk::args::usage {*}$opts $id]] - } - } - #puts "--->origin $specid queryargs: $specargs" - set origin $specid - set queryargs $specargs - } - - if {[string match "(autodef)*" $origin]} { - #wasn't resolved by id - so take this as a request to generate it (probably there is an existing custom def - and this has been manually requested to get the default) - set origin [string range $origin [string length (autodef)] end] - set resolved $origin - } - - set autoid "" - switch -- $cmdtype { - object { - #class is also an object - #todo -mixins etc etc - set class [info object class $origin] - #the call: info object methods -all - # seems to do the right thing as far as hiding unexported methods, and showing things like destroy - # - which don't seem to be otherwise easily introspectable - set public_methods [info object methods $origin -all] - #set class_methods [info class methods $class] - #set object_methods [info object methods $origin] - - if {[llength $queryargs]} { - set c1 [lindex $queryargs 0] - if {$c1 in $public_methods} { - switch -- $c1 { - new { - set constructorinfo [info class constructor $origin] - set arglist [lindex $constructorinfo 0] - set argdef [punk::lib::tstr -return string { - @id -id "(autodef)${$origin} new" - @cmd -name "${$origin} new"\ - -summary\ - "Create new object instance."\ - -help\ - "create object with autogenerated command name. - Arguments are passed to the constructor." - @values - }] - set i 0 - foreach a $arglist { - if {[llength $a] == 1} { - if {$i == [llength $arglist]-1 && $a eq "args"} { - #'args' is only special if last - append argdef \n "args -optional 1 -multiple 1" - } else { - append argdef \n "$a" - } - } else { - append argdef \n "[lindex $a 0] -default [lindex $a 1]" - } - incr i - } - punk::args::define $argdef - set queryargs_remaining [lrange $queryargs 1 end] - switch -- [dict get $opts -return] { - string { - set estyle "basic" - } - tableobject { - set estyle "minimal" - } - default { - set estyle "standard" - } - } - if {[catch {punk::args::parse $queryargs_remaining -form [dict get $opts -form] -errorstyle $estyle withid "(autodef)$origin new"} parseresult]} { - if {[dict get $opts -return] eq "tableobject"} { - return [punk::args::arg_error "$parseresult" [punk::args::get_spec "(autodef)$origin new"] {*}$opts -aserror 0] - } else { - return $parseresult - } - } else { - if {!$scheme_received} { - dict set opts -scheme info - } - return [punk::args::arg_error "" [punk::args::get_spec "(autodef)$origin new"] {*}$opts -aserror 0 -parsedargs $parseresult] - #return [punk::args::usage {*}$opts "(autodef)$origin new"] - } - } - create { - set constructorinfo [info class constructor $origin] - set arglist [lindex $constructorinfo 0] - set argdef [punk::lib::tstr -return string { - @id -id "(autodef)${$origin} create" - @cmd -name "${$origin} create"\ - -summary\ - "Create new object instance with specified command name."\ - -help\ - "create object with specified command name. - Arguments following objectName are passed to the constructor." - @values -min 1 - objectName -type string -help\ - "possibly namespaced name for object instance command" - }] - set i 0 - foreach a $arglist { - if {[llength $a] == 1} { - if {$i == [llength $arglist]-1 && $a eq "args"} { - #'args' is only special if last - append argdef \n "args -optional 1 -multiple 1" - } else { - append argdef \n "$a" - } - } else { - append argdef \n "[lindex $a 0] -default [lindex $a 1]" - } - incr i - } - punk::args::define $argdef - set queryargs_remaining [lrange $queryargs 1 end] - switch -- [dict get $opts -return] { - string { - set estyle "basic" - } - tableobject { - set estyle "minimal" - } - default { - set estyle "standard" - } - } - if {[catch {punk::args::parse $queryargs_remaining -form [dict get $opts -form] -errorstyle $estyle withid "(autodef)$origin create"} parseresult]} { - if {[dict get $opts -return] eq "tableobject"} { - return [punk::args::arg_error "$parseresult" [punk::args::get_spec "(autodef)$origin create"] {*}$opts -aserror 0] - } else { - return $parseresult - } - } else { - if {!$scheme_received} { - dict set opts -scheme info - } - return [punk::args::arg_error "" [punk::args::get_spec "(autodef)$origin create"] {*}$opts -aserror 0 -parsedargs $parseresult] - #return [punk::args::usage {*}$opts "(autodef)$origin create"] - } - } - destroy { - #review - generally no doc - # but we may want notes about a specific destructor - set argdef [punk::lib::tstr -return string { - @id -id "(autodef)${$origin} destroy" - @cmd -name "destroy"\ - -summary\ - "delete object instance."\ - -help\ - "delete object, calling destructor if any. - destroy accepts no arguments." - @values -min 0 -max 0 - }] - punk::args::define $argdef - set queryargs_remaining [lrange $queryargs 1 end] - switch -- [dict get $opts -return] { - string { - set estyle "basic" - } - tableobject { - set estyle "minimal" - } - default { - set estyle "standard" - } - } - if {[catch {punk::args::parse $queryargs_remaining -form [dict get $opts -form] -errorstyle $estyle withid "(autodef)$origin destroy"} parseresult]} { - if {[dict get $opts -return] eq "tableobject"} { - return [punk::args::arg_error "$parseresult" [punk::args::get_spec "(autodef)$origin destroy"] {*}$opts -aserror 0] - } else { - return $parseresult - } - } else { - if {!$scheme_received} { - dict set opts -scheme info - } - return [punk::args::arg_error "" [punk::args::get_spec "(autodef)$origin destroy"] {*}$opts -aserror 0 -parsedargs $parseresult] - #return [punk::args::usage {*}$opts "(autodef)$origin destroy"] - } - } - default { - #use info object call to resolve callchain - #we assume the first impl is the topmost in the callchain - # and its call signature is therefore the one we are interested in - REVIEW - # we should probably ignore generaltypes filter|unknown and look for a subsequent method|private? - set implementations [::info object call $origin $c1] - #result documented as list of 4 element lists - #set callinfo [lindex $implementations 0] - set oodef "" - foreach impl $implementations { - lassign $impl generaltype mname location methodtype - switch -- $generaltype { - method - private { - #objects being dynamic systems - we should always reinspect. - #Don't use the cached (autodef) def - #If there is a custom def override - use it (should really be -dynamic - but we don't check) - if {$location eq "object"} { - set idcustom "$origin $c1" - #set id "[string trimleft $origin :] $c1" ;# " " - if {[info commands ::punk::args::id_exists] ne ""} { - if {[punk::args::id_exists $idcustom]} { - return [uplevel 1 [list punk::args::usage {*}$opts $idcustom]] - } - } - set oodef [::info object definition $origin $c1] - } else { - #set id "[string trimleft $location :] $c1" ;# " " - set idcustom "$location $c1" - if {[info commands ::punk::args::id_exists] ne ""} { - if {[punk::args::id_exists $idcustom]} { - return [uplevel 1 [list punk::args::usage {*}$opts $idcustom]] - } - } - set oodef [::info class definition $location $c1] - } - break - } - filter { - } - unknown { - } - } - } - if {$oodef ne ""} { - set autoid "(autodef)$location $c1" - set arglist [lindex $oodef 0] - set argdef [punk::lib::tstr -return string { - @id -id "${$autoid}" - @cmd -name "${$location} ${$c1}" -help\ - "(autogenerated by arginfo) - arglist:${$arglist}" - @values - }] - set i 0 - #for 9.1+ can use -integer - foreach a $arglist { - switch -- [llength $a] { - 1 { - if {$i == [llength $arglist]-1 && $a eq "args"} { - #'args' is only special if last - append argdef \n "args -optional 1 -multiple 1" - } else { - append argdef \n "$a" - } - } - 2 { - append argdef \n "[lindex $a 0] -default {[lindex $a 1]} -optional 1" - } - default { - error "punk::ns::arginfo unexpected oo argument signature '$arglist'\noodef:$oodef\nimplementations:$implementations" - } - } - incr i - } - punk::args::define $argdef - return [punk::args::usage {*}$opts $autoid] - } else { - return "unable to resolve $origin method $c1" - } - - } - } - } - } - set choicelabeldict [dict create] - set choiceinfodict [dict create] - foreach cmd $public_methods { - switch -- $cmd { - new - create - destroy { - #todo - } - default { - set implementations [::info object call $origin $cmd] - set def "" - foreach impl $implementations { - lassign $impl generaltype mname location methodtype - switch -- $generaltype { - method - private { - if {$location eq "object" || $location eq $origin} { - #set id "[string trimleft $origin :] $cmd" ;# " " - set id "$origin $cmd" - dict set choiceinfodict $cmd {{doctype objectmethod}} - } elseif {$location eq $class} { - set id "$class $cmd" - dict set choiceinfodict $cmd {{doctype classmethod}} - } else { - #set id "[string trimleft $location :] $cmd" ;# " " - set id "$location $cmd" - if {[string match "core method:*" $methodtype]} { - dict lappend choiceinfodict $cmd {doctype coremethod} - } else { - dict lappend choiceinfodict $cmd [list doctype [list $location $methodtype]] - } - } - if {[punk::args::id_exists $id]} { - #dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]" - dict lappend choiceinfodict $cmd {doctype punkargs} - dict lappend choiceinfodict $cmd [list subhelp {*}$id] - } - break - } - filter { - } - unknown { - dict set choiceinfodict $cmd {{doctype unknown}} - } - } - } - } - } - } - - set vline [list method -choices $public_methods -choicelabels $choicelabeldict -choiceinfo $choiceinfodict -choiceprefix 0] ;#methods must be specified in full always? - review - #puts stderr "--->$vline" - set autoid "(autodef)$origin" - set argdef [punk::lib::tstr -return string { - @id -id ${$autoid} - @cmd -name "Object: ${$origin}" -help\ - "Instance of class: ${$class} (info autogenerated)" - @leaders -min 1 - }] - append argdef \n $vline - punk::args::define $argdef - - } - privateObject { - return "Command is a privateObject - no info currently available" - } - privateClass { - return "Command is a privateClass - no info currently available" - } - interp { - #todo - } - script { - #todo - } - ensemble { - #review - #todo - check -unknown - #if there is a -unknown handler - we can't be sure the choices in -map or from -namespace are exhaustive. - #presumably -choiceprefix should be zero in that case?? - - set ensembleinfo [namespace ensemble configure $origin] - set parameters [dict get $ensembleinfo -parameters] - set prefixes [dict get $ensembleinfo -prefixes] - set map [dict get $ensembleinfo -map] - set ns [dict get $ensembleinfo -namespace] - - #review - we can have a combination of commands from -map as well as those exported from -namespace - # if and only if -subcommands is specified - - set subcommand_dict [dict create] - set commands [list] - set nscommands [list] - if {[llength [dict get $ensembleinfo -subcommands]]} { - #set exportspecs [namespace eval $ns {namespace export}] - #foreach pat $exportspecs { - # lappend nscommands {*}[info commands ${ns}::$pat] - #} - #when using -subcommands, even unexported commands are available - set nscommands [info commands ${ns}::*] - foreach sub [dict get $ensembleinfo -subcommands] { - if {[dict exists $map $sub]} { - #-map takes precence over same name exported from -namespace - dict set subcommand_dict $sub [dict get $map $sub] - } elseif {"${ns}::$sub" in $nscommands} { - dict set subcommand_dict $sub ${ns}::$sub - } else { - #subcommand probably supplied via -unknown handler? - dict set subcommand_dict $sub "" - } - } - } else { - if {[dict size $map]} { - set subcommand_dict $map - } else { - set exportspecs [namespace eval $ns {namespace export}] - foreach pat $exportspecs { - lappend nscommands {*}[info commands ${ns}::$pat] - } - foreach fqc $nscommands { - dict set subcommand_dict [namespace tail $fqc] $fqc - } - } - } - - - set subcommands [lsort [dict keys $subcommand_dict]] - if {[llength $queryargs]} { - set posn_subcommand [llength $parameters];#ensemble may have '-parameters' list specified - parameters that come before the subcommand - if {$posn_subcommand > 0} { - set params [lrange $queryargs 0 $posn_subcommand-1] - set remaining_queryargs [lrange $queryargs $posn_subcommand end] - } else { - set params [list] - set remaining_queryargs $queryargs - } - if {[llength $remaining_queryargs]} { - if {$prefixes} { - set match [tcl::prefix::match -error {} $subcommands [lindex $remaining_queryargs 0]] - } else { - set match [lindex $remaining_queryargs 0] - } - if {$match in $subcommands} { - set subcmd [dict get $subcommand_dict $match] - #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") - if {!$scheme_received} { - dict unset opts -scheme - } - #return [arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] - #use tailcall so %caller% is reported properly in error msg - tailcall arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") - } - } - } - - #todo - synopsis? - set choicelabeldict [dict create] - - set choiceinfodict [dict create] - - dict for {sub subwhat} $subcommand_dict { - if {[llength $subwhat] > 1} { - #TODO - resolve using cmdinfo? - puts stderr "arginfo warning: subcommand $sub points to multiword target $subwhat - TODO" - } - set targetfirstword [lindex $subwhat 0] - set targetinfo [cmdwhich $targetfirstword] - set targetorigin [dict get $targetinfo origin] - set targetcmdtype [dict get $targetinfo origintype] - set nstarget [nsprefix $targetorigin] - - dict lappend choiceinfodict $sub [list doctype $targetcmdtype] - - if {[punk::args::id_exists [list $origin $sub]]} { - dict lappend choiceinfodict $sub {doctype punkargs} - dict lappend choiceinfodict $sub [list subhelp {*}$origin $sub] - } elseif {[punk::args::id_exists $targetorigin]} { - dict lappend choiceinfodict $sub {doctype punkargs} - dict lappend choiceinfodict $sub [list subhelp {*}$targetorigin] - } else { - #puts stderr "arginfo ensemble--- NO doc for [list $origin $sub] or $origin" - } - - } - - set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict -choiceinfo $choiceinfodict] - set autoid "(autodef)$origin" - puts "ENSEMBLE auto def $autoid (arginfo)" - set argdef [punk::lib::tstr -return string { - @id -id ${$autoid} - @cmd -help\ - "(autogenerated by arginfo) - ensemble: ${$origin}" - }] - if {[llength $parameters] == 0} { - append argdef \n "@leaders -min 1" - } else { - append argdef \n "@leaders -min [expr {[llength $parameters]+1}]" - foreach p $parameters { - append argdef \n "$p -type string -help { (leading ensemble parameter)}" - } - } - append argdef \n "@values -unnamed true" - append argdef \n $vline - punk::args::define $argdef - } - } - - #if {$autoid ne ""} { - # return [punk::args::usage {*}$opts $autoid] - #} - - - #check ensemble before testing punk::arg::id_exists - #we want to recalculate ensemble usage info in case ensemble has been modified - - if {$autoid ne ""} { - switch -- [dict get $opts -return] { - string { - set estyle "basic" - } - tableobject { - set estyle "minimal" - } - default { - set estyle "standard" - } - } - if {[catch {punk::args::parse $queryargs -form [dict get $opts -form] -errorstyle $estyle withid $autoid} parseresult]} { - # parsing error e.g Bad number of leading values - #override -scheme in opts with -scheme error - if {[dict get $opts -return] eq "tableobject"} { - return [punk::args::arg_error "$parseresult" [punk::args::get_spec $autoid] {*}$opts -aserror 0] - } else { - return $parseresult - } - } else { - #show usage - with goodargs marked - #return [punk::args::arg_error "" [punk::args::get_spec $autoid] -scheme info -aserror 0 {*}$opts -parsedargs $parseresult] - if {!$scheme_received} { - dict set opts -scheme info - } - return [punk::args::arg_error "" [punk::args::get_spec $autoid] {*}$opts -aserror 0 -parsedargs $parseresult] - } - #return [punk::args::usage {*}$opts $autoid] - } - - #check for tepam help - if {[info exists ::tepam::ProcedureList]} { - if {$origin in $::tepam::ProcedureList} { - return [tepam::ProcedureHelp $origin 1] ;#use 1 to return rather than emit to stdout - } else { - #handle any tepam functions that don't eat their own dogfood but have help variables - #e.g tepam::procedure, tepam::argument_dialogbox - #Rather than hardcode these - we'll guess that any added will use the same scheme.. - if {[namespace qualifiers $origin] eq "::tepam"} { - set func [namespace tail $origin] - #tepam XXXHelp vars don't exactly match procedure names :/ - if {[info exists ::tepam::${func}Help]} { - return [set ::tepam::${func}Help] - } else { - set f2 [string totitle $func] - if {[info exists ::tepam::${f2}Help]} { - return [set ::tepam::${f2}Help] - } - #e.g argument_dialogbox -> ArgumentDialogboxHelp - set parts [split $func _] - set uparts [lmap p $parts {string totitle $p}] - set f3 [join [list {*}$uparts Help] ""] - if {[info exists ::tepam::${f3}]} { - return [set ::tepam::${f3}] - } - } - } - } - } - - set origin_ns [nsprefix $origin] - set parts [nsparts_cached $origin_ns] - set weird_ns 0 - if {[lsearch $parts :*] >=0} { - set weird_ns 1 - } - if {$weird_ns} { - set argl {} - set tail [nstail $origin] - set cmdtype [nseval_ifexists $origin_ns [list punk::ns::cmdtype $tail]] - if {$cmdtype eq "proc"} { - foreach a [nseval_ifexists $origin_ns [list info args $tail]] { - if {[nseval_ifexists $origin_ns [list info default $tail $a def]]} { - lappend a $def - } - lappend argl $a - } - } - } else { - set cmdtype [punk::ns::cmdtype $origin] - if {$cmdtype eq "proc"} { - set argl {} - set infoargs [info args $origin] - foreach a $infoargs { - if {[info default $origin $a def]} { - lappend a $def - } - lappend argl $a - } - } - } - - if {[llength $queryargs]} { - #todo - something better ? - switch -- [dict get $opts -return] { - string { - set estyle "basic" - } - tableobject { - set estyle "minimal" - } - default { - set estyle "standard" - } - } - - if {[punk::args::id_exists $origin]} { - if {[catch {punk::args::parse $queryargs -form [dict get $opts -form] -errorstyle $estyle withid $origin} parseresult]} { - if {[dict get $opts -return] eq "tableobject"} { - return [punk::args::arg_error "$parseresult" [punk::args::get_spec $origin] {*}$opts -aserror 0] - } else { - return $parseresult - } - } else { - #show usage - with goodargs marked - if {!$scheme_received} { - dict set opts -scheme info - } - return [punk::args::arg_error "" [punk::args::get_spec $origin] {*}$opts -aserror 0 -parsedargs $parseresult] - } - } - set msg "Undocumented or nonexistant command $origin $queryargs" - append msg \n "$origin Type: $cmdtype" - } else { - if {$cmdtype eq "proc"} { - set msg "Undocumented proc $origin" - append msg \n "No argument processor detected" - append msg \n "function signature: $resolved $argl" - } else { - set msg "Undocumented command $origin. Type: $cmdtype" - } - } - if {[llength $grepstr] != 0} { - if {[llength $grepstr] == 1} { - return [punk::grepstr -no-linenumbers -highlight red [lindex $grepstr 0] $msg] - } else { - return [punk::grepstr -no-linenumbers -highlight [lrange $grepstr 1 end] [lindex $grepstr 0] $msg] - } - } - return $msg - } - - #todo - package up as navns - punk::args::define { - @id -id ::punk::ns::corp - @cmd -name punk::ns::corp -help\ - "Show alias or proc information. - 'corp' (being the reverse spelling of proc) - will display the Tcl 'proc name args body' statement - for the proc. - Essentially this is a convenient way to display the - proc body including argument info, instead of - separately calling 'info args ' 'info body ' - etc. - The body may display with an additional - comment inserted to display information such as the - namespace origin. Such a comment begins with #corp#." - @opts - -syntax -default basic -choices {none basic}\ - -choicelabels { - none\ - " Plain text output" - basic\ - " Comment and bracket highlights. - This is a basic colourizer - not - a full Tcl syntax highlighter." - }\ - -help\ - "Type of syntax highlighting on result. - Note that -syntax none will always return a proper Tcl - List: proc - - but a syntax highlighter may return a string that - is not a Tcl list." - @values -min 1 -max -1 - commandname -help\ - "May be either the fully qualified path for the command, - or a relative name that is resolvable from the current - namespace." - } - proc corp {args} { - set argd [punk::args::parse $args withid ::punk::ns::corp] - set path [dict get $argd values commandname] - set syntax [dict get $argd opts -syntax] - #thanks to Richard Suchenwirth for the original - wiki.tcl-lang.org/page/corp - #Note: modified here to support aliases and relative/absolute name (with respect to namespace .ie ::name vs name) - if {[info exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - set indent [string repeat " " $tw] ;#match - #set indent [string repeat " " $tw] ;#A more sensible default for code - review - - if {[info exists ::auto_index($path)]} { - set body "\n${indent}#corp# auto_index $::auto_index($path)" - } else { - set body "" - } - - #we want to handle edge cases of commands such as "" or :x - #various builtins such as 'namespace which' won't work - if {[string match ::* $path]} { - set targetns [nsprefix $path] - set name [nstail $path] - } else { - set thispath [uplevel 1 [list ::nsthis $path]] - set targetns [nsprefix $thispath] - set name [nstail $thispath] - } - #puts stderr "corp upns:$upns" - - #set name [string trim $name :] - #set origin [namespace origin ${upns}::$name] - set origin [nseval $targetns [list ::namespace origin $name]] - set resolved [nseval $targetns [list ::namespace which $name]] - - #A renamed alias may exist that is the same name as a proc that was created later.. so we must check for the proc before looking into aliases! - #set iproc [info procs $origin] ;#This will find empty-string command as ::ns:: but miss finding proc ":x" as ::ns:::x - set iproc [nsjoin $targetns [nseval $targetns [list ::info procs $name]]] - if {$origin ni $iproc} { - - #It seems an interp alias of "::x"" behaves the same as "x" - #But we can't create both at the same time - and they have to be queried by the exact name. - #So we query for alias with and without leading :: - set alias_qualified [interp alias {} [string trim $origin :]] - set alias_unqualified [interp alias {} $origin] - if {[string length $alias_qualified] && [string length $alias_unqualified]} { - #our assumptions are wrong.. change in tcl version? - puts stderr "corp: Found alias for unqualified name:'[string trim $origin :]' and qualified name: '$origin' - unexpected (assumed impossible as at Tcl 8.6)" - if {$alias_qualified ne $alias_unqalified} { - - } else { - set alias $alias_unqualified - } - } else { - set alias ${alias_qualified}${alias_unqualified} ;#concatenate - as at least one should be empty - } - - if {[string length $alias]} { - #todo - consider following alias-chain to ultimate proc? - #it can always be manually done with: - #.= corp $name |/1> corp |/1> corp .. - #depending on number of aliases in the chain - return [list alias {*}$alias] - } - } - if {[nsprefix $origin] ne [nsprefix [nsjoin ${targetns} $name]]} { - append body \n "${indent}#corp# namespace origin $origin" - } - - if {$body ne "" && [string index $body end] ne "\n"} { - append body \n - } - if {![catch {package require textutil::tabify} errpkg]} { - #set bodytext [info body $origin] - set bodytext [nseval $targetns [list ::info body $name]] - #punk::lib::indent preserves trailing empty lines - unlike textutil version - set bodytext [punk::lib::undent [textutil::untabify2 $bodytext $tw]] - append body [punk::lib::indent $bodytext $indent] - } else { - #append body [info body $origin] - #relevant test test::punk::ns SUITE ns corp.test corp_leadingcolon_functionname - append body [nseval $targetns [list ::info body $name]] - } - set argl {} - set argnames [nseval $targetns [list ::info args $name]] - foreach a $argnames { - #if {[info default $origin $a defvar]} { - # lappend a $defvar - #} - set result [nseval $targetns [string map [list %n% $name %a% $a] { - #qualify all command names when running in arbitrary namespace - ::if {[::info default "%n%" "%a%" punk_ns_corp_defvar]} { - ::return [::list default $punk_ns_corp_defvar][::unset punk_ns_corp_defvar] ;#keep the targetns tidy - } else { - ::return [::list none] - } - }]] - if {[lindex $result 0] eq "default"} { - lappend a [lindex $result 1] - } - lappend argl $a - } - #list proc [nsjoin ${targetns} $name] $argl $body - switch -- $syntax { - basic { - #rudimentary colourising only - set argl [punk::grepstr -return all -highlight tk-darkcyan {\{|\}} $argl] - set body [punk::grepstr -return all -highlight green {^\s*#.*} $body] ;#Note, will not highlight comments at end of line - like this one. - set body [punk::grepstr -return all -highlight green {;\s*(#.*)} $body] ;#treat as tail comment only if preceeded by semicolon - set body [punk::grepstr -return all -highlight tk-darkcyan {\{|\}} $body] - set body [punk::grepstr -return all -highlight tk-orange {\[|\]} $body] - #ansi colourised items in list format may not always have desired string representation (list escaping can occur) - #return as a string - which may not be a proper Tcl list! - return "proc $resolved {$argl} {\n$body\n}" - } - } - list proc $resolved $argl $body - } - - - #review ??? - proc ns_relative_to_location {name} { - if {[string match ::* $name]} { - error "ns_relative_to_location accepts a relative namespace name only ie one without leading ::" - } - - } - proc ns_absolute_to_location {name} { - - } - - - tcl::namespace::eval internal { - - - #maintenance: similar in punk::winrun - proc get_run_opts {options alias_dict arglist} { - if {[catch { - set callerinfo [info level -1] - } errM]} { - set caller "" - } else { - set caller [lindex $callerinfo 0] - } - - #update alias dict mapping shortnames to longnames - longnames to self - foreach o $options { - dict set alias_dict $o $o - } - set known_runopts [dict keys $alias_dict] - set runopts [list] - set cmdargs [list] - - set first_eopt_posn [lsearch $arglist --] - if {$first_eopt_posn >=0} { - set pre_eopts [lrange $arglist 0 $first_eopt_posn-1] - set is_eopt_for_runopts 1 ;#default assumption that it is for this function rather than part of user's commandline - cycle through previous args to disprove. - foreach pre $pre_eopts { - if {$pre ni $known_runopts} { - set is_eopt_for_runopts 0; #the first -- isn't for us. - } - } - } else { - set is_eopt_for_runopts 0 - } - #split on first -- if only known opts preceding (or nothing preceeding) - otherwise split on first arg that doesn't look like an option and bomb if unrecognised flags before it. - if {$is_eopt_for_runopts} { - set idx_first_cmdarg [expr $first_eopt_posn + 1] - set runopts [lrange $arglist 0 $idx_first_cmdarg-2] ;#exclude -- from runopts - it's just a separator. - } else { - set idx_first_cmdarg [lsearch -not $arglist "-*"] - set runopts [lrange $arglist 0 $idx_first_cmdarg-1] - } - set cmdargs [lrange $arglist $idx_first_cmdarg end] - foreach o $runopts { - if {$o ni $known_runopts} { - error "$caller: Unknown runoption $o - known options $known_runopts" - } - } - set runopts [lmap o $runopts {dict get $alias_dict $o}] - #todo - get these out of here. Should be supplied by caller. - if {"-allowvars" in $runopts && "-disallowvars" in $runopts} { - puts stderr "Warning - conflicting options -allowvars & -disallowvars specified: $arglist" - } - - #maintain order: runopts $runopts cmdargs $cmdargs as first 4 args (don't break 'lassign [get_runopts $args] _ runopts _ cmdargs') - #todo - add new keys after these indicating type of commandline etc. - return [list runopts $runopts cmdargs $cmdargs] - } - - proc _pkguse_vars {varnames} { - #review - obsolete? - while {"pkguse_vars_[incr n]" in $varnames} {} - #return [concat $varnames pkguse_vars_$n] - return [list {*}$varnames pkguse_vars_$n] - } - proc tracehandler_nowrite {args} { - error "readonly in use block" + proc _pkguse_vars {varnames} { + #review - obsolete? + while {"pkguse_vars_[incr n]" in $varnames} {} + #return [concat $varnames pkguse_vars_$n] + return [list {*}$varnames pkguse_vars_$n] + } + proc tracehandler_nowrite {args} { + error "readonly in use block" } } @@ -5845,6 +5889,10 @@ tcl::namespace::eval punk::ns { +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punk::ns ::punk::ns::argdoc +} diff --git a/src/modules/punk/repl-999999.0a1.0.tm b/src/modules/punk/repl-999999.0a1.0.tm index 623422a8..9e3c98bd 100644 --- a/src/modules/punk/repl-999999.0a1.0.tm +++ b/src/modules/punk/repl-999999.0a1.0.tm @@ -3177,7 +3177,7 @@ namespace eval repl { variable errstack {} variable outstack {} variable run_command_cache - proc set_clone {varname obj} { + proc set_valcopy {varname obj} { append obj2 $obj {} uplevel 1 [list set $varname $obj2] } @@ -3241,6 +3241,7 @@ namespace eval repl { #} set pkgs [list\ punk::ansi::colourmap\ + punk::assertion\ punk::args\ punk::pipe\ cmdline\ @@ -3256,7 +3257,6 @@ namespace eval repl { textutil\ punk::encmime\ punk::char\ - punk::assertion\ punk::ansi\ punk::lib\ overtype\ @@ -3290,37 +3290,41 @@ namespace eval repl { set prior_infoscript [code eval {info script}] ;#probably empty that's ok foreach pkg $pkgs { #puts stderr "---> init_script safe pkg: $pkg" - if {[catch { - set nsquals [namespace qualifiers $pkg] - if {$nsquals ne ""} { - if {![dict exists $ns_scanned $nsquals]} { - catch {package require $pkg 1-0} ;#force scan with nonsatisfiable version - dict set ns_scanned $nsquals 1 + #only load from source if not already loaded (perhaps already present from another package loading it) + set vloaded [code eval [list package provide $pkg]] + if {$vloaded eq ""} { + if {[catch { + set nsquals [namespace qualifiers $pkg] + if {$nsquals ne ""} { + if {![dict exists $ns_scanned $nsquals]} { + catch {package require $pkg 1-0} ;#force scan with nonsatisfiable version + dict set ns_scanned $nsquals 1 + } } - } - set versions [lsort -command {package vcompare} [package versions $pkg]] - if {[llength $versions]} { - set v [lindex $versions end] - set path [lindex [package ifneeded $pkg $v] end] - if {[file extension $path] in {.tcl .tm}} { - if {![catch {readFile $path} data]} { - code eval [list info script $path] - code eval $data - code eval [list info script $prior_infoscript] + set versions [lsort -command {package vcompare} [package versions $pkg]] + if {[llength $versions]} { + set v [lindex $versions end] + set path [lindex [package ifneeded $pkg $v] end] + if {[file extension $path] in {.tcl .tm}} { + if {![catch {readFile $path} data]} { + code eval [list info script $path] + code eval $data + code eval [list info script $prior_infoscript] + } else { + error "safe - failed to read $path" + } } else { - error "safe - failed to read $path" + error "safe - refusing to attempt load of $pkg from $path - (allowed extensions .tcl .tm)" } } else { - error "safe - refusing to attempt load of $pkg from $path - (allowed extensions .tcl .tm)" + error "safe - no versions of $pkg found" } + } errMsg]} { + puts stderr "safe - failed to load package $pkg\n$errMsg\n$::errorInfo" } else { - error "safe - no versions of $pkg found" + #puts stdout "---> init_script safe - loaded $pkg from $path" + #puts stdout "---> v [code eval [list package provide $pkg]]" } - } errMsg]} { - puts stderr "safe - failed to load package $pkg\n$errMsg\n$::errorInfo" - } else { - #puts stdout "---> init_script safe - loaded $pkg from $path" - #puts stdout "---> v [code eval [list package provide $pkg]]" } } @@ -3337,7 +3341,7 @@ namespace eval repl { #review code alias ::shellfilter::stack ::shellfilter::stack - #code alias ::punk::lib::set_clone ::punk::lib::set_clone + #code alias ::punk::lib::set_valcopy ::punk::lib::set_valcopy #code alias ::aliases ::punk::ns::aliases code alias ::punk::ns::aliases ::punk::ns::aliases namespace eval ::codeinterp {} diff --git a/src/modules/punk/repl/codethread-999999.0a1.0.tm b/src/modules/punk/repl/codethread-999999.0a1.0.tm index a4839ae5..a0fbb998 100644 --- a/src/modules/punk/repl/codethread-999999.0a1.0.tm +++ b/src/modules/punk/repl/codethread-999999.0a1.0.tm @@ -196,8 +196,8 @@ tcl::namespace::eval punk::repl::codethread { #otherwise when $script goes out of scope - internal rep of vars set in script changes. #The shimmering may be no big deal(?) - but debug/analysis using tcl::unsupported::representation becomes impossible. - #interp eval code [list ::punk::lib::set_clone ::codeinterp::clonescript $script] ;#like objclone - interp eval code [list ::codeinterp::set_clone ::codeinterp::clonescript $script] ;#like objclone + #interp eval code [list ::punk::lib::set_valcopy ::codeinterp::clonescript $script] ;#like valcopy + interp eval code [list ::codeinterp::set_valcopy ::codeinterp::clonescript $script] ;#like valcopy interp eval code {lappend ::codeinterp::run_command_cache $::codeinterp::clonescript} diff --git a/src/modules/punk/unixywindows-999999.0a1.0.tm b/src/modules/punk/unixywindows-999999.0a1.0.tm index b53123d4..951efa6a 100644 --- a/src/modules/punk/unixywindows-999999.0a1.0.tm +++ b/src/modules/punk/unixywindows-999999.0a1.0.tm @@ -35,35 +35,35 @@ namespace eval punk::unixywindows { if {![string length $cachedunixyroot]} { if {![catch { set result [exec cygpath -m /] ;# -m gives result with forward-slashes - which is ok for windows paths in a Tcl context. - set cachedunixyroot [punk::objclone $result] + set cachedunixyroot [punk::valcopy $result] file pathtype $cachedunixyroot; #this call causes the int-rep to be path #set ::punk::last_run_display [list] ;#hack - review shouldn't really be necessary.. but because we call winpath from ./ - the repl looks for last_run_display } errM]} { } else { puts stderr "Warning: Failed to determine base for unix-like paths - using default of c:/msys2" - file pathtype [set cachedunixyroot [punk::objclone "c:/msys2"]] + file pathtype [set cachedunixyroot [punk::valcopy "c:/msys2"]] } } #will have been shimmered from string to 'path' internal rep by 'file pathtype' call #let's return a different copy as it's so easy to lose path-rep - set copy [punk::objclone $cachedunixyroot] + set copy [punk::valcopy $cachedunixyroot] return $copy } proc refresh_unixyroot {} { variable cachedunixyroot set result [exec cygpath -m /] ;# -m gives result with forward-slashes - which is ok for windows paths in a Tcl context. - set cachedunixyroot [punk::objclone $result] + set cachedunixyroot [punk::valcopy $result] file pathtype $cachedunixyroot; #this call causes the int-rep to be path - set copy [punk::objclone $cachedunixyroot] + set copy [punk::valcopy $cachedunixyroot] return $copy } proc set_unixyroot {windows_path} { variable cachedunixyroot file pathtype $windows_path - set cachedunixyroot [punk::objclone $windows_path] + set cachedunixyroot [punk::valcopy $windows_path] #return the original - but probably int-rep will have shimmered to path even if started out as string #- that's probably what we want. Caller can use as string or path without affecting cachedunixyroot return $windows_path @@ -131,13 +131,13 @@ namespace eval punk::unixywindows { } #puts stderr "->$driveletters" - set path [punk::objclone $unixypath] ;#take another copy that we can deliberatley shimmer to path and know is separate to the supplied argument + set path [punk::valcopy $unixypath] ;#take another copy that we can deliberatley shimmer to path and know is separate to the supplied argument set supplied_pathtype [file pathtype $path] ;#we don't care about the pathtype so much as the act of making this call shimmers to a path internal-rep #copy of var that we can treat as a string without affecting path rep #Note that some but not all read operations will lose path rep e.g 'string length $x' will lose any path-rep $x had, (but 'string equal $x something' won't) #Todo - make int-rep tests to check stability of these behaviours across Tcl versions! - set strcopy_path [punk::objclone $path] + set strcopy_path [punk::valcopy $path] set str_newpath "" @@ -174,7 +174,7 @@ namespace eval punk::unixywindows { #dunno - pass through set pathobj $path } else { - set pathobj [punk::objclone $str_newpath] + set pathobj [punk::valcopy $str_newpath] file pathtype $pathobj } } diff --git a/src/modules/punk/winpath-999999.0a1.0.tm b/src/modules/punk/winpath-999999.0a1.0.tm index 8fa5ef7e..334a19c3 100644 --- a/src/modules/punk/winpath-999999.0a1.0.tm +++ b/src/modules/punk/winpath-999999.0a1.0.tm @@ -30,7 +30,7 @@ namespace eval punk::winpath { #\\servername\share etc or \\?\UNC\servername\share etc. proc is_unc_path {path} { - set strcopy_path [punk::winpath::system::objclone $path] + set strcopy_path [punk::winpath::system::valcopy $path] set strcopy_path [string map {\\ /} $strcopy_path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway) if {[string first "//" $strcopy_path] == 0} { #check for "Dos device path" syntax @@ -77,7 +77,7 @@ namespace eval punk::winpath { #dos device path syntax allows windows api to acces extended-length paths and filenames with illegal path characters such as trailing dots or whitespace #(can exist on server shares and on NTFS - but standard apps can't access without dos device syntax) proc is_dos_device_path {path} { - set strcopy_path [punk::winpath::system::objclone $path] + set strcopy_path [punk::winpath::system::valcopy $path] set strcopy_path [string map {\\ /} $strcopy_path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway) if {[string range $strcopy_path 0 3] in {//?/ //./}} { return 1 @@ -100,13 +100,13 @@ namespace eval punk::winpath { proc strip_unc_path_prefix {path} { if {[is_unc_path_plain $path]} { #plain unc //server - set strcopy_path [punk::winpath::system::objclone $path] + set strcopy_path [punk::winpath::system::valcopy $path] set trimmedpath [string range $strcopy_path 2 end] file pathtype $trimmedpath return $trimmedpath } elseif {is_unc_path $path} { #//?/UNC/server/subpath or //./UNC/server/subpath - set strcopy_path [punk::winpath::system::objclone $path] + set strcopy_path [punk::winpath::system::valcopy $path] set trimmedpath [string range $strcopy_path 7 end] file pathtype $trimmedpath ;#shimmer it to path rep return $trimmedpath @@ -153,7 +153,7 @@ namespace eval punk::winpath { error $err } - set strcopy_path [punk::winpath::system::objclone $path] + set strcopy_path [punk::winpath::system::valcopy $path] #Note: path could still have leading double slash if it is a Dos device path: e.g. //?/c:/etc @@ -339,7 +339,7 @@ namespace eval punk::winpath { namespace eval punk::winpath::system { #get a copy of the item without affecting internal rep - proc objclone {obj} { + proc valcopy {obj} { append obj2 $obj {} } } diff --git a/src/modules/punk/winrun-999999.0a1.0.tm b/src/modules/punk/winrun-999999.0a1.0.tm index f24c0cfb..e8dbd778 100644 --- a/src/modules/punk/winrun-999999.0a1.0.tm +++ b/src/modules/punk/winrun-999999.0a1.0.tm @@ -310,7 +310,7 @@ namespace eval punk::winrun { set tcl_list [list] set i 0 foreach a $cmdargs { - set copy [internal::objclone $a] + set copy [internal::valcopy $a] append raw_cmdline "$copy " lappend tcl_list $copy if {$i == 0 && !$quiet} { @@ -333,7 +333,7 @@ namespace eval punk::winrun { #set raw_parts [list] #foreach range $wordranges { # set word [string range $raw_cmdline {*}$range] - # lappend raw_parts [internal::objclone $word] + # lappend raw_parts [internal::valcopy $word] #} @@ -521,7 +521,7 @@ namespace eval punk::winrun { return "Usage: quote_cmd ?runopt? ... ?--? ?cmd? ?cmdarg? ..." } foreach a $cmdargs { - set copy [internal::objclone $a] + set copy [internal::valcopy $a] append raw_cmdline "$copy " lappend tcl_list $copy } @@ -632,7 +632,7 @@ namespace eval punk::winrun { set verbose [expr {"-verbose" in $runopts}] #review - may need to force quoting of barewords by quote_win to ensure proper behaviour if bareword contains cmd specials? #?always treatable as a list? review - set tcl_list [lmap v $cmdargs {internal::objclone $v}] + set tcl_list [lmap v $cmdargs {internal::valcopy $v}] set meta_chars [list {<} {>} & |] ;#caret-quote when outside of cmd.exe's idea of a quoted section - carets will disappear from passed on string set cmdline "" set in_quotes 0 @@ -721,7 +721,7 @@ namespace eval punk::winrun { set allowvars [expr {"-allowvars" in $runopts}] set verbose [expr {"-verbose" in $runopts}] - set tcl_list [lmap v $cmdargs {internal::objclone $v}] + set tcl_list [lmap v $cmdargs {internal::valcopy $v}] set meta_chars [list {"} "(" ")" ^ < > & |] if {!$allowvars} { lappend meta_chars % ! @@ -764,7 +764,7 @@ namespace eval punk::winrun { set allowvars [expr {"-allowvars" in $runopts}] set allowquotes [expr {"-allowquotes" in $runopts}] set verbose [expr {"-verbose" in $runopts}] - set tcl_list [lmap v $cmdargs {internal::objclone $v}] + set tcl_list [lmap v $cmdargs {internal::valcopy $v}] set cmdline "" set i 0 set meta_chars [list "(" ")" ^ < > & |] @@ -797,7 +797,7 @@ namespace eval punk::winrun { proc quote_cmd2 {args} { set cmdargs $args - set tcl_list [lmap v $cmdargs {internal::objclone $v}] + set tcl_list [lmap v $cmdargs {internal::valcopy $v}] set cmdline "" set i 0 @@ -906,7 +906,7 @@ namespace eval punk::winrun { # -- --- --- #get a copy of the item without affecting internal rep #this isn't critical for most usecases - but can be of use for example when trying not to shimmer path objects to strings (filesystem performance impact in some cases) - proc objclone {obj} { + proc valcopy {obj} { append obj2 $obj {} } # -- --- ---