From 0b10aa8cab5f326d3410fee0848d322ab92d1647 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Mon, 30 Jun 2025 01:57:35 +1000 Subject: [PATCH] punk::args option grouping, more tclcore docs --- src/modules/punk-0.1.tm | 23 +- src/modules/punk/args-999999.0a1.0.tm | 1448 +++++++++++----- src/modules/punk/args-buildversion.txt | 2 +- src/modules/punk/args/tclcore-999999.0a1.0.tm | 1500 +++++++++++++++-- src/modules/punk/console-999999.0a1.0.tm | 6 +- src/modules/punk/lib-999999.0a1.0.tm | 1 + src/modules/punk/ns-999999.0a1.0.tm | 97 +- src/modules/punk/zip-999999.0a1.0.tm | 13 +- src/modules/shellrun-0.1.1.tm | 107 +- .../args-0.1.5_testsuites/args/args.test | 14 + .../args-0.1.5_testsuites/args/synopsis.test | 97 +- src/modules/textblock-999999.0a1.0.tm | 176 +- 12 files changed, 2771 insertions(+), 713 deletions(-) diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index 8f971e3b..b92b106e 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -6803,9 +6803,18 @@ namespace eval punk { punk::args::define { @dynamic @id -id ::punk::LOC - @cmd -name punk::LOC -help\ + @cmd -name punk::LOC\ + -summary\ + "Lines Of Code counter"\ + -help\ "LOC - lines of code. - An implementation of a notoriously controversial metric" + An implementation of a notoriously controversial metric. + Returns a dict or dictionary-display containing various + counts such as: + 'loc' - total lines of code. + 'purepunctuationlines' - lines consisting soley of punctuation. + 'filecount' - number of files examined." + @opts -return -default showdict -choices {dict showdict} -dir -default "\uFFFF" -exclude_dupfiles -default 1 -type boolean @@ -6820,13 +6829,18 @@ namespace eval punk { } " #we could map away whitespace and use string is punct - but not as flexible? review -punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] } - " + " { + @values + fileglob -type string -default * -optional 1 -multiple 1 -help\ + "glob patterns to match against the filename portion (last segment) of each + file path. e.g *.tcl *.tm" + } } #An implementation of a notoriously controversial metric. proc LOC {args} { set argd [punk::args::parse $args withid ::punk::LOC] lassign [dict values $argd] leaders opts values received - set searchspecs [dict values $values] + set searchspecs [dict get $values fileglob] # -- --- --- --- --- --- set opt_return [dict get $opts -return] @@ -7344,6 +7358,7 @@ namespace eval punk { 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 ./ "?subdir?" "view/change directory"] lappend cmdinfo [list ../ "" "go up one directory"] lappend cmdinfo [list ./new "subdir" "make new directory and switch to it"] diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index 7fdc7a4f..432712aa 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -376,17 +376,28 @@ tcl::namespace::eval punk::args { %B%@id%N% ?opt val...? directive-options: -id %B%@cmd%N% ?opt val...? - directive-options: -name -help + directive-options: -name + -summary + -help %B%@leaders%N% ?opt val...? (used for leading args that come before switches/opts) - directive-options: -min -max -unnamed - (also accepts options as defaults for subsequent arguments) + directive-options: + -min -max (min and max number of leaders) + -unnamed (allow unnamed positional leaders) + -takewhenargsmodulo (assign args to leaders based on modulo + of total number of args. If value is not supplied (or < 2) then + leaders are assigned based on whether configured opts are + encountered, and whether the min number of leaders and values + can be satisfied. In this case optional leaders are assigned if + the type of the argument can be matched.) + (also accepts options as defaults for subsequent leader definitions) %B%@opts%N% ?opt val...? directive-options: -any|-arbitrary + (also accepts options as defaults for subsequent flag definitions) %B%@values%N% ?opt val...? (used for trailing args that come after switches/opts) directive-options: -min -max -unnamed - (also accepts options as defaults for subsequent arguments) + (also accepts options as defaults for subsequent value definitions) %B%@form%N% ?opt val...? (used for commands with multiple forms) directive-options: -form -synopsis @@ -650,7 +661,11 @@ tcl::namespace::eval punk::args { -regexprepass {}\ -validationtransform {}\ -prefix 1\ + -parsekey ""\ + -group ""\ ] + #parsekey is name of argument to use as a key in punk::args::parse result dicts + set valdirective_defaults [tcl::dict::create\ -type string\ -optional 0\ @@ -677,6 +692,7 @@ tcl::namespace::eval punk::args { LEADER_NAMES [list]\ LEADER_MIN ""\ LEADER_MAX ""\ + LEADER_TAKEWHENARGSMODULO 0\ LEADER_UNNAMED false\ LEADERSPEC_DEFAULTS $leaderdirective_defaults\ LEADER_CHECKS_DEFAULTS {}\ @@ -689,6 +705,7 @@ tcl::namespace::eval punk::args { OPT_SOLOS {}\ OPTSPEC_DEFAULTS $optdirective_defaults\ OPT_CHECKS_DEFAULTS {}\ + OPT_GROUPS {}\ VAL_DEFAULTS [tcl::dict::create]\ VAL_REQUIRED [list]\ VAL_NAMES [list]\ @@ -1232,6 +1249,9 @@ tcl::namespace::eval punk::args { } cmd { #allow arbitrary - review + #e.g -name + # -summary + # -help set cmd_info [dict merge $cmd_info $at_specs] } doc { @@ -1289,6 +1309,37 @@ tcl::namespace::eval punk::args { #} tcl::dict::set tmp_optspec_defaults -type $v } + -parsekey { + tcl::dict::set tmp_optspec_defaults -parsekey $v + + } + -group { + tcl::dict::set tmp_optspec_defaults -group $v + if {$v ne "" && ![tcl::dict::exists $F $fid OPT_GROUPS $v]} { + tcl::dict::set F $fid OPT_GROUPS $v {-parsekey {} -help {}} + } + if {$v ne ""} { + if {[tcl::dict::exists $at_specs -parsekey]} { + tcl::dict::set F $fid OPT_GROUPS $v -parsekey [tcl::dict::get $at_specs -parsekey] + } + } + } + -grouphelp { + if {![tcl::dict::exists $at_specs -group]} { + error "punk::args::resolve Bad @opt line. -group entry is required if -grouphelp is being configured. @id:$DEF_definition_id" + } + set g [tcl::dict::get $at_specs -group] + if {$g eq ""} { + error "punk::args::resolve Bad @opt line. -group non-empty value is required if -grouphelp is being configured. @id:$DEF_definition_id" + } + set groupdict [tcl::dict::get $F $fid OPT_GROUPS] + #set helprecords [tcl::dict::get $F $fid OPT_GROUPS_HELP] + if {![tcl::dict::exists $groupdict $g]} { + tcl::dict::set F $fid OPT_GROUPS $g [dict create -parsekey {} -help $v] + } else { + tcl::dict::set F $fid OPT_GROUPS $g -help $v + } + } -range { if {[dict exists $at_specs -type]} { set tp [dict get $at_specs -type] @@ -1333,7 +1384,8 @@ tcl::namespace::eval punk::args { tcl::dict::set tmp_optspec_defaults $k $v } default { - set known { -any -anyopts -arbitrary -form -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo\ + set known { -parsekey -group -grouphelp\ + -any -anyopts -arbitrary -form -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo\ -type -range -typeranges -default -typedefaults -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted -nocase\ -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ @@ -1376,6 +1428,9 @@ tcl::namespace::eval punk::args { } dict set F $fid LEADER_MAX $v } + -takewhenargsmodulo { + dict set F $fid LEADER_TAKEWHENARGSMODULO $v + } -choiceprefix - -choicerestricted { if {![string is boolean -strict $v]} { @@ -1717,8 +1772,10 @@ tcl::namespace::eval punk::args { } } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + ##set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS] tcl::dict::set argdef_values -ARGTYPE option + #set all_choices [_resolve_get_record_choices] foreach fid $record_form_ids { if {[dict get $F $fid argspace] eq "leaders"} { @@ -1727,6 +1784,7 @@ tcl::namespace::eval punk::args { error "punk::args::resolve - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" } set record_type option + dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] } @@ -1783,7 +1841,7 @@ tcl::namespace::eval punk::args { } - #assert - we only get here if it is a value or flag specification line. + #assert - we only get here if it is a leader, value or flag specification line. #assert argdef_values has been set to the value of record_values foreach fid $record_form_ids { @@ -1904,6 +1962,9 @@ tcl::namespace::eval punk::args { } tcl::dict::set spec_merged -typesynopsis $specval } + -parsekey - -group { + tcl::dict::set spec_merged -typesynopsis $specval + } -solo - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted - -choicelabels - -choiceinfo - @@ -2001,8 +2062,12 @@ tcl::namespace::eval punk::args { } } } else { - set known_argopts [list -form -type -range -typeranges\ - -default -typedefaults -minsize -maxsize -choices -choicegroups\ + set known_argopts [list\ + -form -type\ + -parsekey -group\ + -range -typeranges\ + -default -typedefaults\ + -minsize -maxsize -choices -choicegroups\ -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted\ -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ @@ -2053,13 +2118,16 @@ tcl::namespace::eval punk::args { if {[tcl::dict::exists $spec_merged -default]} { if {$is_opt} { - #tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] + #JJJ + set parsekey [dict get $F $fid ARG_INFO $argname -default] + if {$parsekey eq ""} { + set parsekey $argname + } tcl::dict::set F $fid OPT_DEFAULTS $argname [tcl::dict::get $spec_merged -default] } else { if {[dict get $F $fid argspace] eq "leaders"} { tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] } else { - #tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] tcl::dict::set F $fid VAL_DEFAULTS $argname [tcl::dict::get $spec_merged -default] } } @@ -2897,7 +2965,8 @@ tcl::namespace::eval punk::args { set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] #puts "-->$cmdinfo" #puts "-->[tcl::info::frame -3]" - while {[string last \n $cmdinfo] >= 1} { + set maxloop 10 ;#failsafe + while {[string last \n $cmdinfo] >= 1 && $maxloop > -1} { #looks like a script - haven't gone up far enough? #(e.g patternpunk oo system: >punk . poses -invalidoption) incr call_level -1 @@ -2919,6 +2988,7 @@ tcl::namespace::eval punk::args { break } } + incr maxloop -1 } set caller [regexp -inline {\S+} $cmdinfo] if {$caller eq "namespace"} { @@ -3249,11 +3319,12 @@ tcl::namespace::eval punk::args { append errmsg \n } } - set cmdname [Dict_getdef $spec_dict cmd_info -name ""] - set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] + set cmdname [Dict_getdef $spec_dict cmd_info -name ""] + set cmdsummary [Dict_getdef $spec_dict cmd_info -summary ""] + set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] - set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] - set docurl [Dict_getdef $spec_dict doc_info -url ""] + set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] + set docurl [Dict_getdef $spec_dict doc_info -url ""] #set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] #set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] @@ -3290,17 +3361,19 @@ tcl::namespace::eval punk::args { set docurl_display "" } #synopsis - set synopsis "" + set synopsis "# [Dict_getdef $spec_dict cmd_info -summary {}]\n" set form_info [dict get $spec_dict form_info] dict for {fid finfo} $form_info { set form_synopsis [Dict_getdef $finfo -synopsis ""] if {$form_synopsis eq ""} { #todo - set form_synopsis [punk::args::synopsis -form $fid [dict get $spec_dict id]] - if {[string length $form_synopsis] > 90} { + set form_synopsis [punk::args::synopsis -noheader -form $fid [dict get $spec_dict id]] + set ansifree_synopsis [punk::ansi::ansistripraw $form_synopsis] + if {[string length $ansifree_synopsis] > 90} { # - set form_synopsis [punk::args::synopsis -return summary -form $fid [dict get $spec_dict id]] + set form_synopsis [punk::args::synopsis -noheader -return summary -form $fid [dict get $spec_dict id]] } + #review if {[string match (autodef)* $form_synopsis]} { set form_synopsis [string range $form_synopsis 9 end] } @@ -3428,17 +3501,18 @@ tcl::namespace::eval punk::args { set opt_names [list] set opt_names_display [list] + set opt_names_hints [list] ;#comments in first column below name display. set lookup_optset [dict create] if {[llength [dict get $form_dict OPT_NAMES]]} { set all_opts [list] - foreach optset [dict get $form_dict OPT_NAMES] { + foreach optionset [dict get $form_dict OPT_NAMES] { #e.g1 "-alias1|-realname" #e.g2 "-f|--filename" (fossil longopt style) #e.g3 "-f|--filename=" (gnu longopt style) - set optmembers [split $optset |] + set optmembers [split $optionset |] lappend all_opts {*}$optmembers foreach o $optmembers { - dict set lookup_optset $o $optset + dict set lookup_optset $o $optionset #goodargs } } @@ -3464,6 +3538,11 @@ tcl::namespace::eval punk::args { $trie destroy foreach optset [dict get $form_dict OPT_NAMES] { set arginfo [dict get $form_dict ARG_INFO $optset] + set parsekey [dict get $arginfo -parsekey] + set storageinfo "" + if {$parsekey ne "" && $parsekey ne $optset} { + set storageinfo "(stored as: $parsekey)" + } if {[dict get $arginfo -prefix]} { set opt_members [split $optset |] set odisplay [list] @@ -3485,12 +3564,23 @@ tcl::namespace::eval punk::args { } else { lappend opt_names_display $optset } + lappend opt_names_hints $storageinfo #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] lappend opt_names $optset } } else { set opt_names [dict get $form_dict OPT_NAMES] - set opt_names_display $opt_names + foreach optset [dict get $form_dict OPT_NAMES] { + set arginfo [dict get $form_dict ARG_INFO $optset] + set parsekey [dict get $arginfo -parsekey] + set storageinfo "" + if {$parsekey ne "" && $parsekey ne $optset} { + set storageinfo "(stored as: $parsekey)" + } + lappend opt_names_display $optset + lappend opt_names_hints $storageinfo + } + #set opt_names_display $opt_names } } set leading_val_names [dict get $form_dict LEADER_NAMES] @@ -3509,18 +3599,84 @@ tcl::namespace::eval punk::args { # set leading_val_names {} #} set leading_val_names_display $leading_val_names + set leading_val_names_hints {} set trailing_val_names_display $trailing_val_names + set trailing_val_names_hints {} #puts "--> parsedargs: $parsedargs" set parsed_leaders [Dict_getdef $parsedargs leaders {}] set parsed_opts [Dict_getdef $parsedargs opts {}] set parsed_values [Dict_getdef $parsedargs values {}] #display options first then values - foreach argumentclassinfo [list [list leaders $leading_val_names_display $leading_val_names $parsed_leaders] [list opts $opt_names_display $opt_names $parsed_opts] [list values $trailing_val_names_display $trailing_val_names $parsed_values]] { - lassign $argumentclassinfo argumentclass argnames_display argnames parsedvalues - - foreach argshow $argnames_display arg $argnames { + foreach argumentclassinfo [list [list leaders $leading_val_names_display $leading_val_names_hints $leading_val_names $parsed_leaders] [list opts $opt_names_display $opt_names_hints $opt_names $parsed_opts] [list values $trailing_val_names_display $trailing_val_names_hints $trailing_val_names $parsed_values]] { + lassign $argumentclassinfo argumentclass argnames_display argnames_hints argnames parsedvalues + set lastgroup "" + set lastgroup_parsekey "" + foreach argshow $argnames_display hint $argnames_hints arg $argnames { set arginfo [dict get $form_dict ARG_INFO $arg] + + if {$argumentclass eq "opts"} { + set thisgroup [dict get $arginfo -group] + if {$thisgroup ne $lastgroup} { + if {[dict exists $form_dict OPT_GROUPS $thisgroup -parsekey]} { + set thisgroup_parsekey [dict get $form_dict OPT_GROUPS $thisgroup -parsekey] + } else { + set thisgroup_parsekey "" + } + + #footer/line? + if {$use_table} { + $t add_row [list " " "" "" "" ""] + } else { + lappend errlines " " + } + + if {$thisgroup eq ""} { + } else { + #SHOW group 'header' (not really a table header - just another row) + set help "" + if {[dict exists $form_dict OPT_GROUPS $thisgroup -help]} { + set help [dict get $form_dict OPT_GROUPS $thisgroup -help] + } + if {$thisgroup_parsekey eq ""} { + set groupinfo "(documentation group)" + } else { + set groupinfo "(common flag group)\nkey:$thisgroup_parsekey" + } + if {$use_table} { + $t add_row [list " $thisgroup" $groupinfo "" "" $help] + if {$arg eq $badarg} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG + } elseif {$arg in $goodargs || $thisgroup_parsekey in $goodargs} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_GOODARG + } + } else { + #review - formatting will be all over the shop due to newlines in typesshow, help + #set arghelp "[a+ bold] $thisgroup$RST $groupinfo" + set arghelp [textblock::join -- "[a+ bold] $thisgroup$RST" " " $groupinfo] + append arghelp \n + if {$arg eq $badarg} { + set arghelp [punk::ansi::ansiwrap -rawansi $A_BADARG $arghelp] + } elseif {$arg in $goodargs} { + set arghelp [punk::ansi::ansiwrap -rawansi $A_GOODARG $arghelp] + } + foreach ln [split $help \n] { + append arghelp " $ln" \n + } + lappend errlines $arghelp + } + } + set lastgroup $thisgroup + set lastgroup_parsekey $thisgroup_parsekey + } + if {[dict exists $arginfo -parsekey]} { + set mypkey [dict get $arginfo -parsekey] + if {$mypkey eq "$lastgroup_parsekey" || $mypkey eq [string trimright [lindex [split $arg |] end] =]} { + set hint "" + } + } + } + if {[dict exists $arginfo -default]} { set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" } else { @@ -3849,7 +4005,12 @@ tcl::namespace::eval punk::args { } if {$use_table} { - $t add_row [list $argshow $typeshow $default $multiple $help] + if {$hint ne ""} { + set col1 $argshow\n$hint + } else { + set col1 $argshow + } + $t add_row [list $col1 $typeshow $default $multiple $help] if {$arg eq $badarg} { $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG } elseif {$arg in $goodargs} { @@ -3857,7 +4018,13 @@ tcl::namespace::eval punk::args { } } else { #review - formatting will be all over the shop due to newlines in typesshow, help - set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" + set linetail " TYPE:$typeshow DEFAULT:$default MULTI:$multiple" + if {$hint ne ""} { + set arghelp [textblock::join -- "[a+ bold]$argshow\n$hint$RST" $linetail] + } else { + set arghelp "[a+ bold]$argshow$RST $linetail" + } + append arghelp \n if {$arg eq $badarg} { set arghelp [punk::ansi::ansiwrap -rawansi $A_BADARG $arghelp] } elseif {$arg in $goodargs} { @@ -4171,7 +4338,10 @@ tcl::namespace::eval punk::args { }]} { #unhappy path - not enough options #review - which form of punk::args::parse? - punk::args::parse $args withid ::punk::args::parse + #we expect this to always raise error - review + set result [punk::args::parse $args withid ::punk::args::parse] + puts stderr "punk::args::parse unexpected result $result" + return ;#failsafe } incr i -1 #lappend opts $a [lindex $opts_and_vals $i] @@ -4413,23 +4583,39 @@ tcl::namespace::eval punk::args { #we shouldn't have an optional clause member if there is only one member - the whole name should be marked -optional true instead. set tp [string trim $tp ?] foreach tp_member [split $tp |] { - if {[string match literal* $tp]} { - set litinfo [string range $tp 7 end] ;#get bracketed part if of form literal(xxx) - if {[string match (*) $litinfo]} { - set match [string range $litinfo 1 end-1] - } else { - #plain "literal" without bracketed specifier - match to argument name - set match $clausename + switch -glob $tp { + literal* { + set litinfo [string range $tp 7 end] ;#get bracketed part if of form literal(xxx) + if {[string match (*) $litinfo]} { + set match [string range $litinfo 1 end-1] + } else { + #plain "literal" without bracketed specifier - match to argument name + set match $clausename + } + if {$v eq $match} { + set alloc_ok 1 + lpop all_remaining + if {![dict get $ARG_INFO $clausename -multiple]} { + lpop tailnames + } + #the type (or one of the possible type alternates) matched a literal + break + } } - if {$v eq $match} { - set alloc_ok 1 - lpop all_remaining - if {![dict get $ARG_INFO $clausename -multiple]} { - lpop tailnames + "stringprefix(*" { + set pfx [string range $tp 13 end-1] + if {[string match "$pfx*" $v} { + set alloc_ok 1 + set alloc_ok 1 + lpop all_remaining + if {![dict get $ARG_INFO $clausename -multiple]} { + lpop tailnames + } + break } - #type (or one of the possible type alternates) matched a literal - break + } + default {} } } if {!$alloc_ok} { @@ -4464,54 +4650,71 @@ tcl::namespace::eval punk::args { set clause_member_optional 0 } set tp [string trim $tp ?] - if {[string match literal* $tp]} { - set litinfo [string range $tp 7 end] - if {[string match (*) $litinfo]} { - set match [string range $litinfo 1 end-1] - } else { - #if membername empty - equivalent to "literal()" - matches empty string literal - #edgecase - possibly? no need for empty-string literals - but allow it without error. - set match $membername - } - #todo -literalprefix - if {$rv eq $match} { - set alloc_ok 1 ;#we need at least one literal-match to set alloc_ok - incr alloc_count - } else { - if {$clause_member_optional} { - # + switch -glob $tp { + literal* { + set litinfo [string range $tp 7 end] + if {[string match (*) $litinfo]} { + set match [string range $litinfo 1 end-1] } else { - set alloc_ok 0 - break + #if membername empty - equivalent to "literal()" - matches empty string literal + #edgecase - possibly? no need for empty-string literals - but allow it without error. + set match $membername + } + #todo -literalprefix + if {$rv eq $match} { + set alloc_ok 1 ;#we need at least one literal-match to set alloc_ok + incr alloc_count + } else { + if {$clause_member_optional} { + # + } else { + set alloc_ok 0 + break + } } } - } else { - if {$clause_member_optional} { - #review - optional non-literal makes things harder.. - #we don't want to do full type checking here - but we now risk allocating an item that should actually - #be allocated to the previous value - set prev_type [lindex $rtypelist $reverse_type_index+1] - if {[string match literal* $prev_type]} { - set litinfo [string range $prev_type 7 end] - #todo -literalprefix - if {[string match (*) $litinfo]} { - set match [string range $litinfo 1 end-1] + "stringprefix(*" { + set pfx [string range $tp 13 end-1] + if {[string match "$pfx*" $tp]} { + set alloc_ok 1 + incr alloc_count + } else { + if {$clause_member_optional} { + # } else { - #prev membername - set match [lindex $rclausename $reverse_type_index+1] + set alloc_ok 0 + break } - if {$rv ne $match} { - #current val doesn't match previous type - allocate here + } + } + default { + if {$clause_member_optional} { + #review - optional non-literal makes things harder.. + #we don't want to do full type checking here - but we now risk allocating an item that should actually + #be allocated to the previous value + set prev_type [lindex $rtypelist $reverse_type_index+1] + if {[string match literal* $prev_type]} { + set litinfo [string range $prev_type 7 end] + #todo -literalprefix + if {[string match (*) $litinfo]} { + set match [string range $litinfo 1 end-1] + } else { + #prev membername + set match [lindex $rclausename $reverse_type_index+1] + } + if {$rv ne $match} { + #current val doesn't match previous type - allocate here + incr alloc_count + } + } else { + #no literal to anchor against.. incr alloc_count } } else { - #no literal to anchor against.. + #allocate regardless of type - we're only matching on arity and literal positioning here. + #leave final type-checking for later. incr alloc_count } - } else { - #allocate regardless of type - we're only matching on arity and literal positioning here. - #leave final type-checking for later. - incr alloc_count } } incr reverse_type_index @@ -4566,54 +4769,113 @@ tcl::namespace::eval punk::args { set member_satisfied 0 #----------------------------------------------------------------------------------- - #first build list of any literals - and whether any are literalprefix - set literals [list] - set literalprefixes [list] - set nonliterals [list] + #first build category lists of any literal,literalprefix,stringprefix,other + # + set ctg_literals [list] + set ctg_literalprefixes [list] + set ctg_stringprefixes [list] + set ctg_other [list] set dict_member_match [dict create] foreach tp_member [split $tp |] { #JJJJ - if {[string match literal* $tp_member]} { - if {[string match literalprefix* $tp_member]} { - set litinfo [string range $tp_member 13 end] - if {[string match (*) $litinfo]} { - lappend literalprefixes [string range $litinfo 1 end-1] - } else { - lappend literalprefixes $membername - } - dict set dict_member_match $tp_member [lindex $literalprefixes end] - } else { - set litinfo [string range $tp_member 7 end] - if {[string match (*) $litinfo]} { - lappend literals [string range $litinfo 1 end-1] + switch -glob -- $tp_member { + literal* { + if {[string match literalprefix* $tp_member]} { + set litinfo [string range $tp_member 13 end] + if {[string match (*) $litinfo]} { + lappend ctg_literalprefixes [string range $litinfo 1 end-1] + } else { + lappend ctg_literalprefixes $membername + } + dict set dict_member_match $tp_member [lindex $ctg_literalprefixes end] } else { - lappend literals $membername + set litinfo [string range $tp_member 7 end] + if {[string match (*) $litinfo]} { + lappend ctg_literals [string range $litinfo 1 end-1] + } else { + lappend ctg_literals $membername + } + dict set dict_member_match $tp_member [lindex $ctg_literals end] } - dict set dict_member_match $tp_member [lindex $literals end] } - } else { - lappend nonliterals $tp_member + "stringprefix(*" { + set pfx [string range $tp_member 13 end-1] + lappend ctg_stringprefixes $pfx + } + default { + lappend ctg_other $tp_member + } } } #----------------------------------------------------------------------------------- #asert - each tp_member is a key in dict_member_match - if {[llength $nonliterals] > 0} { - #presence of any ordinary type as one of the alternates - means we consider it a match - #we don't validate here -leave validation for later (review) - set member_satisfied 1 - } else { - if {$v in $literals} { + if {[llength $ctg_other] > 0} { + #presence of any ordinary type as one of the alternates - means we consider it a match if certain basic types align + #we don't do full validation here -leave main validation for later (review) + foreach tp_member $ctg_other { + switch -exact -- $tp_member { + int { + if {[string is integer -strict $v]} { + set member_satisfied 1 + break + } + } + double { + if {[string is double -strict $v]} { + set member_satisfied 1 + break + } + } + bool { + if {[string is boolean -strict $v]} { + set member_satisfied 1 + break + } + } + number { + if {[string is integer -strict $v] || [string is double -strict $v]} { + set member_satisfied 1 + break + } + } + dict { + if {[string is dict $v]} { + set member_satisfied 1 + break + } + } + default { + #REVIEW!!! + #can get infinite loop in get_dict if not satisfied - unstoppable until memory exhausted. + #todo - catch/detect in caller + set member_satisfied 1 + break + } + } + } + } + if {!$member_satisfied && ([llength $ctg_literals] || [llength $ctg_literalprefixes])} { + if {$v in $ctg_literals} { set member_satisfied 1 } else { - #literals is included in the prefix-calc - but a shortened version of an entry in literals is not allowed + #ctg_literals is included in the prefix-calc - but a shortened version of an entry in literals is not allowed #(exact match would have been caught in other branch of this if) - set full_v [tcl::prefix::match -error "" [list {*}$literals {*}$literalprefixes] $v] - if {$full_v ne "" && $full_v ni $literals} { - #matched prefix must be for one of the entries in literalprefixes - valid + #review - how does ctg_stringprefixes affect prefix calc for literals? + set full_v [tcl::prefix::match -error "" [list {*}$ctg_literals {*}$ctg_literalprefixes] $v] + if {$full_v ne "" && $full_v ni $ctg_literals} { + #matched prefix must be for one of the entries in ctg_literalprefixes - valid set member_satisfied 1 } } } + if {!$member_satisfied && [llength $ctg_stringprefixes]} { + foreach pfx $ctg_stringprefixes { + if {[string match "$pfx*" $v]} { + set member_satisfied 1 + break + } + } + } #foreach tp_member [split $tp |] { # if {[string match literal* $tp_member]} { @@ -4677,9 +4939,11 @@ tcl::namespace::eval punk::args { #so that they are not subject to type validation #such elements shouldn't be subject to validation if {$alloc_ok} { - set d [dict create consumed $alloc_count resultlist $resultlist typelist $newtypelist] + #puts stderr ">>>_get_dict_can_assign_value idx:$idx v:[lindex $values $idx] consumed:$alloc_count thistype:$thistype" + set d [dict create consumed $alloc_count resultlist $resultlist typelist $newtypelist] } else { - set d [dict create consumed 0 resultlist {} typelist $thistype] + puts stderr ">>>_get_dict_can_assign_value idx:$idx v:[lindex $values $idx] consumed:$alloc_count thistype:$thistype" + set d [dict create consumed 0 resultlist {} typelist $thistype] } #puts ">>>> _get_dict_can_assign_value $d" return $d @@ -4702,8 +4966,8 @@ tcl::namespace::eval punk::args { set defaults [dict create\ -form *\ ] - set opts [dict merge $defaults $args] - dict for {k v} $opts { + set proc_opts [dict merge $defaults $args] + dict for {k v} $proc_opts { switch -- $k { -form {} default { @@ -4763,7 +5027,7 @@ tcl::namespace::eval punk::args { tcl::dict::with argspecs {} ;#turn keys into vars #e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info,id_info,form_names # ----------------------------------------------- - set opt_form [dict get $opts -form] + set opt_form [dict get $proc_opts -form] if {$opt_form eq "*"} { set selected_forms $form_names } elseif {[string is integer -strict $opt_form]} { @@ -4863,206 +5127,249 @@ tcl::namespace::eval punk::args { #puts stderr "get_dict--> remaining_rawargs: $remaining_rawargs" #} + set can_have_leaders 1 ;#default assumption + if {$LEADER_MAX == 0 || ([llength $LEADER_NAMES] == 0 && !$LEADER_UNNAMED)} { + set can_have_leaders 0 + } #REVIEW - this attempt to classify leaders vs opts vs values doesn't account for leaders with clauses containing optional elements #e.g @leadrs {x -type {int ?int?}} set nameidx 0 - if {$LEADER_MAX != 0} { - for {set ridx 0} {$ridx < [llength $rawargs]} {incr ridx} { - set raw [lindex $rawargs $ridx] ;#received raw arg - if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { - break - } - if {[llength $LEADER_NAMES] && $nameidx == [llength $LEADER_NAMES]-1} { - #at last named leader - set leader_posn_name [lindex $LEADER_NAMES $nameidx] - if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { - set is_multiple 1 - } - } elseif {$ridx > $named_leader_args_max-1} { - #beyond names - retain name if -multiple was true - if {!$is_multiple} { - set leader_posn_name "" - } - } else { - set leader_posn_name [lindex $LEADER_NAMES $nameidx] ;#may return empty string - } - if {$OPT_MAX ne "0"} { - #all_opts includes end_of_opts marker -- if configured - no need to explicitly check for it separately - set flagname $raw - if {[string match --* $raw]} { - set eposn [string first = $raw] - # --flag=xxx - if {$eposn >=3} { - set flagname [string range $raw 0 $eposn-1] - } - } - set matchopt [::tcl::prefix::match -error {} $all_opts $flagname] - if {$matchopt ne ""} { - #flaglike matches a known flag - don't treat as leader + if {$can_have_leaders} { + if {$LEADER_TAKEWHENARGSMODULO} { + #assign set of leaders purely based on number of total args + set take [expr {[llength $remaining_rawargs] % $LEADER_TAKEWHENARGSMODULO}] + set pre_values [lrange $remaining_rawargs 0 $take-1] + set remaining_rawargs [lrange $remaining_rawargs $take end] + } else { + #greedy taking of leaders based on type-matching + + set leadernames_seen [list] + for {set ridx 0} {$ridx < [llength $rawargs]} {incr ridx} { + set raw [lindex $rawargs $ridx] ;#received raw arg + if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { break } - } - - #for each branch - break or lappend - if {$leader_posn_name ne ""} { - set leader_type [dict get $ARG_INFO $leader_posn_name -type] - #todo - variable clauselengths e.g 'if' command which has optional 'then' and 'else' "noise words" - set clauselength [llength $leader_type] - set min_clauselength 0 - foreach t $leader_type { - if {![string match {\?*\?} $t]} { - incr min_clauselength + if {[llength $LEADER_NAMES] && $nameidx == [llength $LEADER_NAMES]-1} { + #at last named leader + set leader_posn_name [lindex $LEADER_NAMES $nameidx] + if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { + set is_multiple 1 } - } - if {$leader_posn_name ni $LEADER_REQUIRED} { - #optional leader - - #most adhoc arg processing will allocate based on number of args rather than matching choice values first - #(because a choice value could be a legitimate data value) - - #review - option to process in this manner? - #first check if the optional leader value is a match for a choice ? - #if {[dict exists $arg_info $leader_posn_name -choices]} { - # set vmatch [tcl::prefix match -error "" [dict get $arg_info $leader_posn_name -choices] $raw] - # if {$vmatch ne ""} { - # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values - # lappend pre_values [lpop remaining_rawargs 0] - # incr ridx - # continue - # } - #} - if {[llength $remaining_rawargs] < $min_clauselength} { - #not enough remaining args to fill even this optional leader - #rather than raise error here - perform our break (for end of leaders) and let the code below handle it - break + } elseif {$ridx > $named_leader_args_max-1} { + #beyond names - retain name if -multiple was true + if {!$is_multiple} { + set leader_posn_name "" } - - #check if enough remaining_rawargs to fill any required values - if {$valmin > 0 && [llength $remaining_rawargs] - $min_clauselength < $valmin} { + } else { + set leader_posn_name [lindex $LEADER_NAMES $nameidx] ;#may return empty string + } + if {$OPT_MAX ne "0" && [string match -* $raw]} { + #all_opts includes end_of_opts marker -- if configured - no need to explicitly check for it separately + set possible_flagname $raw + if {[string match --* $raw]} { + set eposn [string first = $raw] + # --flag=xxx + if {$eposn >=3} { + set possible_flagname [string range $raw 0 $eposn-1] + } + } + set matchopt [::tcl::prefix::match -error {} $all_opts $possible_flagname] + if {$matchopt ne ""} { + #flaglike matches a known flag - don't treat as leader break } + } - #leadername may be a 'clause' of arbitrary length (e.g -type {int double} or {int string number}) - set end_leaders 0 + #for each branch - break or lappend + if {$leader_posn_name ne ""} { + set leader_type [dict get $ARG_INFO $leader_posn_name -type] + #todo - variable clauselengths e.g 'if' command which has optional 'then' and 'else' "noise words" + set clauselength [llength $leader_type] + set min_clauselength 0 foreach t $leader_type { - set raw [lindex $rawargs $ridx] - if {[string match {\?*\?} $t] && [string match -* $raw]} { - #review - limitation of optional leaders is they can't be same value as any defined flags/opts - set flagname $raw - if {[string match --* $raw]} { - set eposn [string first = $raw] - # --flag=xxx - if {$eposn >=3} { - set flagname [string range $raw 0 $eposn-1] - } - } - set matchopt [::tcl::prefix::match -error {} $all_opts $flagname] - if {$matchopt ne ""} { - #don't consume if flaglike (and actually matches an opt) - set end_leaders 1 - break ;#break out of looking at -type members in the clause - } else { - #unrecognised flag - treat as value for optional member of the clause - lappend pre_values [lpop remaining_rawargs 0] - incr ridx - } - } else { - lappend pre_values [lpop remaining_rawargs 0] - incr ridx + if {![string match {\?*\?} $t]} { + incr min_clauselength } } - incr ridx -1 ;#leave ridx at index of last r that we set - if {$end_leaders} { - break - } - if {!$is_multiple} { - incr nameidx - } - dict incr leader_posn_names_assigned $leader_posn_name - } else { - #clause is required - if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { - #already accepted at least one complete clause for this name - requirement satisfied - now equivalent to optional + if {$leader_posn_name ni $LEADER_REQUIRED} { + #optional leader + + #most adhoc arg processing will allocate based on number of args rather than matching choice values first + #(because a choice value could be a legitimate data value) + + #review - option to process in this manner? + #first check if the optional leader value is a match for a choice ? + #if {[dict exists $arg_info $leader_posn_name -choices]} { + # set vmatch [tcl::prefix match -error "" [dict get $arg_info $leader_posn_name -choices] $raw] + # if {$vmatch ne ""} { + # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values + # lappend pre_values [lpop remaining_rawargs 0] + # incr ridx + # continue + # } + #} if {[llength $remaining_rawargs] < $min_clauselength} { #not enough remaining args to fill even this optional leader #rather than raise error here - perform our break (for end of leaders) and let the code below handle it break } + #check if enough remaining_rawargs to fill any required values if {$valmin > 0 && [llength $remaining_rawargs] - $min_clauselength < $valmin} { break } - } - #if we didn't break - requirement is not yet satisfied, or is satisfied but still enough remaining_rawargs for required values - #we still need to check if enough values for the leader itself - if {[llength $remaining_rawargs] < $min_clauselength} { - #not enough remaining args to fill *required* leader - break - } - set end_leaders 0 - foreach t $leader_type { - set raw [lindex $rawargs $ridx] - if {[string match {\?*\?} $t] && [string match -* $raw]} { - #review - limitation of optional leaders is they can't be same value as any defined flags/opts - - set matchopt [::tcl::prefix::match -error {} $all_opts $raw] - if {$matchopt ne ""} { - #don't consume if flaglike (and actually matches an opt) - set end_leaders 1 - break ;#break out of looking at -type members in the clause - } else { - #unrecognised flag - treat as value for optional member of the clause + #leadername may be a 'clause' of arbitrary length (e.g -type {int double} or {int string number}) + set end_leaders 0 + set tentative_pre_values [list] + set tentative_idx $ridx + if {$OPT_MAX ne "0"} { + foreach t $leader_type { + set raw [lindex $rawargs $tentative_idx] + if {[string match {\?*\?} $t] && [string match -* $raw]} { + #review - limitation of optional leaders is they can't be same value as any defined flags/opts + set flagname $raw + if {[string match --* $raw]} { + set eposn [string first = $raw] + # --flag=xxx + if {$eposn >=3} { + set flagname [string range $raw 0 $eposn-1] + } + } + set matchopt [::tcl::prefix::match -error {} $all_opts $flagname] + if {$matchopt ne ""} { + #don't consume if flaglike (and actually matches an opt) + set end_leaders 1 + break ;#break out of looking at -type members in the clause + } else { + #unrecognised flag - treat as value for optional member of the clause + #lappend pre_values [lpop remaining_rawargs 0] + lappend tentative_pre_values $raw + incr tentative_idx + } + } else { + #lappend pre_values [lpop remaining_rawargs 0] + lappend tentative_pre_values $raw + incr tentative_idx + } + } + if {$end_leaders} { + break + } + } else { + foreach t $leader_type { + #JJJ + set raw [lindex $rawargs $tentative_idx] + #lappend pre_values [lpop remaining_rawargs 0] + lappend tentative_pre_values $raw + incr tentative_idx + } + } + set assign_d [_get_dict_can_assign_value 0 $tentative_pre_values 0 [list $leader_posn_name] $leadernames_seen $formdict] + set consumed [dict get $assign_d consumed] + set resultlist [dict get $assign_d resultlist] + set newtypelist [dict get $assign_d typelist] + if {$consumed != 0} { + if {$leader_posn_name ni $leadernames_seen} { + lappend leadernames_seen $leader_posn_name + } + dict incr leader_posn_names_assigned $leader_posn_name + for {set c 0} {$c < $consumed} {incr c} { lappend pre_values [lpop remaining_rawargs 0] - incr ridx } + incr ridx $consumed + incr ridx -1 ;#leave ridx at index of last r that we set } else { - lappend pre_values [lpop remaining_rawargs 0] - incr ridx + } - } - incr ridx -1 - if {$end_leaders} { - break - } - if {!$is_multiple} { - incr nameidx - } - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #unnamed leader - if {$LEADER_MIN ne "" } { - if {$ridx > $LEADER_MIN-1} { - if {$LEADER_MAX ne "" && $ridx == $LEADER_MAX} { + if {!$is_multiple} { + incr nameidx + } + } else { + #clause is required + if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { + #already accepted at least one complete clause for this name - requirement satisfied - now equivalent to optional + if {[llength $remaining_rawargs] < $min_clauselength} { + #not enough remaining args to fill even this optional leader + #rather than raise error here - perform our break (for end of leaders) and let the code below handle it + break + } + + if {$valmin > 0 && [llength $remaining_rawargs] - $min_clauselength < $valmin} { + break + } + } + #if we didn't break - requirement is not yet satisfied, or is satisfied but still enough remaining_rawargs for required values + #we still need to check if enough values for the leader itself + if {[llength $remaining_rawargs] < $min_clauselength} { + #not enough remaining args to fill *required* leader break - } else { - if {$valmin > 0} { - if {[llength $remaining_rawargs] > $valmin} { - lappend pre_values [lpop remaining_rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name + } + + set end_leaders 0 + foreach t $leader_type { + set raw [lindex $rawargs $ridx] + if {[string match {\?*\?} $t] && [string match -* $raw]} { + #review - limitation of optional leaders is they can't be same value as any defined flags/opts + + set matchopt [::tcl::prefix::match -error {} $all_opts $raw] + if {$matchopt ne ""} { + #don't consume if flaglike (and actually matches an opt) + set end_leaders 1 + break ;#break out of looking at -type members in the clause } else { - break + #unrecognised flag - treat as value for optional member of the clause + lappend pre_values [lpop remaining_rawargs 0] + incr ridx } } else { lappend pre_values [lpop remaining_rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name + incr ridx } } - } else { - #haven't reached LEADER_MIN - lappend pre_values [lpop remaining_rawargs 0] + incr ridx -1 + if {$end_leaders} { + break + } + if {!$is_multiple} { + incr nameidx + } dict incr leader_posn_names_assigned $leader_posn_name } } else { - #review - if is_multiple, keep going if enough remaining_rawargs for values? - break + #unnamed leader + if {$LEADER_MIN ne "" } { + if {$ridx > $LEADER_MIN-1} { + if {$LEADER_MAX ne "" && $ridx == $LEADER_MAX} { + break + } else { + if {$valmin > 0} { + if {[llength $remaining_rawargs] > $valmin} { + lappend pre_values [lpop remaining_rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } else { + break + } + } else { + lappend pre_values [lpop remaining_rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } + } else { + #haven't reached LEADER_MIN + lappend pre_values [lpop remaining_rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } else { + #review - if is_multiple, keep going if enough remaining_rawargs for values? + break + } } - } - #incr ridx - } ;# end foreach r $rawargs_copy + #incr ridx + } ;# end foreach r $rawargs_copy + } } #puts "get_dict ================> pre: $pre_values" @@ -5075,13 +5382,21 @@ tcl::namespace::eval punk::args { set leadermin $LEADER_MIN } if {$LEADER_MAX eq ""} { - set leadermax -1 + if {[llength $LEADER_NAMES] == 0 && !$LEADER_UNNAMED} { + set leadermax 0 + } else { + set leadermax -1 + } } else { set leadermax $LEADER_MAX } if {$VAL_MAX eq ""} { - set valmax -1 + if {[llength $VAL_NAMES] == 0 && !$VAL_UNNAMED} { + set valmax 0 + } else { + set valmax -1 + } } else { set valmax $VAL_MAX } @@ -5090,12 +5405,6 @@ tcl::namespace::eval punk::args { #assert - remaining_rawargs has been reduced by leading positionals set opts [dict create] ;#don't set to OPT_DEFAULTS here - #set id [dict get $argspecs id] - #if {$id eq "::if"} { - #puts stderr "::if" - #puts stderr "get_dict--> pre_values: $pre_values" - #puts stderr "get_dict--> remaining_rawargs: $remaining_rawargs" - #} set leaders [list] set arglist {} @@ -5123,32 +5432,8 @@ tcl::namespace::eval punk::args { break } set a [lindex $remaining_rawargs $i] - #if {$a eq "--"} { - # #REVIEW - # #remaining num args <= valmin already covered above - # if {$valmax != -1} { - # #finite max number of vals - # if {$remaining_args_including_this == $valmax} { - # #assume it's a value. - # set arglist [lrange $remaining_rawargs 0 $i-1] - # set post_values [lrange $remaining_rawargs $i end] - # } else { - # #assume it's an end-of-options marker - # lappend flagsreceived -- - # set arglist [lrange $remaining_rawargs 0 $i] - # set post_values [lrange $remaining_rawargs $i+1 end] - # } - # } else { - # #unlimited number of post_values accepted - # #treat this as eopts - we don't care if remainder look like options or not - # lappend flagsreceived -- - # set arglist [lrange $remaining_rawargs 0 $i] - # set post_values [lrange $remaining_rawargs $i+1 end] - # } - # break - #} - if {[string match --* $a]} { - if {$a eq "--"} { + switch -glob -- $a { + -- { if {$a in $OPT_NAMES} { #treat this as eopts - we don't care if remainder look like options or not lappend flagsreceived -- @@ -5160,35 +5445,37 @@ tcl::namespace::eval punk::args { set post_values [lrange $remaining_rawargs $i end] } break - } else { + } + --* { set eposn [string first = $a] if {$eposn > 2} { #only allow longopt-style = for double leading dash longopts #--*= 2} { #only allow longopt-style = for double leading dash longopts #--*= --x) + lappend flagsreceived $undefined_flagsupplied ;#adhoc flag name (if --x=1 -> --x) } else { if {[llength $OPT_NAMES]} { set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES (3)" @@ -5471,26 +5813,108 @@ tcl::namespace::eval punk::args { #} #--------------------------------------- + #Order the received options by the order in which they are *defined* + #EXCEPT that grouped options using same parsekey must be processed in received order set ordered_opts [dict create] - set unaliased_opts [lmap v $OPT_NAMES {string trimright [lindex [split $v |] end] =}] - #unaliased_opts is list of 'api_opt' (to handle flag aliases of form -a1|-a2|-api_opt) - # e.g -fg|-foreground - # e.g -x|--fullname= - #Resulting unaliased_opts from list {-fg|-foreground -x|--fullname=} should be {-foreground --fullname} - foreach o $unaliased_opts optset $OPT_NAMES { - if {[dict exists $opts $o]} { - dict set ordered_opts $o [dict get $opts $o] - } elseif {[dict exists $OPT_DEFAULTS $optset]} { - dict set ordered_opts $o [dict get $OPT_DEFAULTS $optset] + + #set unaliased_opts [lmap v $OPT_NAMES {string trimright [lindex [split $v |] end] =}] + ##unaliased_opts is list of 'api_opt' (to handle flag aliases of form -a1|-a2|-api_opt) + ## e.g -fg|-foreground + ## e.g -x|--fullname= + ##Resulting unaliased_opts from list {-fg|-foreground -x|--fullname=} should be {-foreground --fullname} + #foreach o $unaliased_opts optset $OPT_NAMES { + # if {[dict exists $opts $o]} { + # dict set ordered_opts $o [dict get $opts $o] + # } elseif {[dict exists $OPT_DEFAULTS $optset]} { + # #JJJ + # set parsekey "" + # if {[tcl::dict::exists $argstate $o -parsekey]} { + # set parsekey [tcl::dict::get $argstate $o -parsekey] + # } + # if {$parsekey eq ""} { + # set parsekey $o + # } + # dict set ordered_opts $parsekey [dict get $OPT_DEFAULTS $optset] + # } + #} + + #puts ">>>>==== $opts" + set seen_pks [list] + #treating opts as list for this loop. + foreach optset $OPT_NAMES { + set parsekey "" + set is_parsekey 0 + if {[tcl::dict::exists $argstate $optset -parsekey]} { + set parsekey [tcl::dict::get $argstate $optset -parsekey] + set is_parsekey 1 + } + if {$parsekey eq ""} { + set is_parsekey 0 + #fall back to last element of aliased option e.g -fg|-foreground -> "-foreground" + set parsekey [string trimright [lindex [split $optset |] end] =] + } + lappend seen_pks $parsekey + set found "" + set foundval "" + #no lsearch -stride avail in 8.6 + foreach {k v} $opts { + if {$k eq $parsekey} { + set found $k + set foundval $v + } + } ;#avoiding further dict/list shimmering + #if {[dict exists $opts $parsekey]} { + # set found $parsekey + # set foundval [dict get $opts $parsekey] + #} + if {$found eq "" && $is_parsekey} { + #.g we may have in opts -decreasing|-SORTDIRECTION -increasing|-SORTDIRECTION + #(where -SORTDIRECTION was configured as -parsekey) + #last entry must win + #NOTE - do not use dict for here. opts is not strictly a dict - dupe keys will cause wrong ordering + foreach {o v} $opts { + if {[string match *|$parsekey $o]} { + set found $o + set foundval $v + #use last match - don't break + } + } + } + if {$found ne ""} { + dict set ordered_opts $found $foundval + } elseif {[tcl::dict::exists $OPT_DEFAULTS $optset]} { + if {$is_parsekey} { + set tailopt [string trimright [lindex [split $optset |] end] =] + if {$tailopt ne $parsekey} { + dict set ordered_opts $tailopt|$parsekey [dict get $OPT_DEFAULTS $optset] + } else { + dict set ordered_opts $parsekey [dict get $OPT_DEFAULTS $optset] + } + } else { + dict set ordered_opts $parsekey [dict get $OPT_DEFAULTS $optset] + } } } + #add in possible arbitrary opts after the defined opts, due to @opts directive flag '-any|-arbitrary true' - dict for {o oval} $opts { - if {![dict exists $ordered_opts $o]} { - dict set ordered_opts $o $oval + #But make sure not to add any repeated parsekey e.g -increasing|-SORT -decreasing|-SORT + #use the seen_pks from the ordered_opts loop above + #keep working with opts only as list here.. + if {[llength $opts] > 2*[dict size $ordered_opts]} { + foreach {o o_val} $opts { + lassign [split $o |] _ pk + if {$pk ne "" && $pk in $seen_pks} { + continue + } + if {![dict exists $ordered_opts $o]} { + dict set ordered_opts $o $o_val + } } } set opts $ordered_opts + #opts is a proper dict now + + #NOTE opts still may contain some entries in non-final form such as -flag|-PARSEKEY #--------------------------------------- @@ -5524,7 +5948,8 @@ tcl::namespace::eval punk::args { set newtypelist [dict get $assign_d typelist] if {[tcl::dict::get $argstate $leadername -optional]} { if {$consumed == 0} { - #error 111 + puts stderr "get_dict cannot assign val:$ldr to leadername:$leadername leaders:$leaders (111)" + #return -options [list -code error -errorcode [list PUNKARGS UNCONSUMED -argspecs $argspecs]] "_get_dict_can_assign_value consumed 0 unexpected 1?" incr ldridx -1 set leadername_multiple "" incr nameidx @@ -5538,7 +5963,8 @@ tcl::namespace::eval punk::args { set msg "Bad number of leaders for %caller%. Not enough remaining values to assign to required arguments (fail on $leadername)." return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingrequiredleader $leadername ] -argspecs $argspecs]] $msg } else { - #error 222 + puts stderr "get_dict cannot assign val:$ldr to leadername:$leadername (222)" + #return -options [list -code error -errorcode [list PUNKARGS UNCONSUMED -argspecs $argspecs]] "_get_dict_can_assign_value consumed 0 unexpected 2?" incr ldridx -1 set leadername_multiple "" incr nameidx @@ -5656,6 +6082,8 @@ tcl::namespace::eval punk::args { set newtypelist [dict get $assign_d typelist] if {[tcl::dict::get $argstate $valname -optional]} { if {$consumed == 0} { + #error 333 + puts stderr "get_dict cannot assign val:$val to valname:$valname (333)" incr validx -1 set valname_multiple "" incr nameidx @@ -5669,6 +6097,8 @@ tcl::namespace::eval punk::args { set msg "Bad number of values for %caller%. Not enough remaining values to assign to required arguments (fail on $valname)." return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingrequiredvalue $valname ] -argspecs $argspecs]] $msg } else { + #error 444 + puts stderr "get_dict cannot assign val:$val to valname:$valname (444)" incr validx -1 set valname_multiple "" incr nameidx @@ -5802,6 +6232,7 @@ tcl::namespace::eval punk::args { } #assertion - opts keys are full-length option names if -any|-arbitrary was false or if the supplied option as a shortname matched one of our defined options + #(and may still contain non-final flag_ident entries such as -increasing|-SORTDIRECTION) #opts explicitly marked as -optional 0 must be present - regardless of -any|-arbitrary (which allows us to ignore additional opts to pass on to next call) @@ -5822,22 +6253,28 @@ tcl::namespace::eval punk::args { # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" #} #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us - if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { - set msg "Required leader missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadermissing $missing received $leadernames_received] -argspecs $argspecs]] $msg - #arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs + if {[llength $LEADER_REQUIRED]} { + if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { + set msg "Required leader missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadermissing $missing received $leadernames_received] -argspecs $argspecs]] $msg + #arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs + } } - set api_opt_required [lmap v $OPT_REQUIRED {lindex [split $v |] end}] - if {[llength [set missing [punklib_ldiff $api_opt_required $flagsreceived]]]} { - set full_missing [dict get $lookup_optset $missing] - set msg "Required option missing for %caller%. missing flags: '$full_missing' are marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list optionmissing $full_missing received $flagsreceived] -argspecs $argspecs]] $msg - #arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs + if {[llength $OPT_REQUIRED]} { + set api_opt_required [lmap v $OPT_REQUIRED {lindex [split $v |] end}] + if {[llength [set missing [punklib_ldiff $api_opt_required $flagsreceived]]]} { + set full_missing [dict get $lookup_optset $missing] + set msg "Required option missing for %caller%. missing flags: '$full_missing' are marked with -optional false - so must be present" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list optionmissing $full_missing received $flagsreceived] -argspecs $argspecs]] $msg + #arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs + } } - if {[llength [set missing [punklib_ldiff $VAL_REQUIRED $valnames_received]]]} { - set msg "Required value missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list valuemissing $missing received $valnames_received] -argspecs $argspecs]] $msg - #arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs + if {[llength $VAL_REQUIRED]} { + if {[llength [set missing [punklib_ldiff $VAL_REQUIRED $valnames_received]]]} { + set msg "Required value missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list valuemissing $missing received $valnames_received] -argspecs $argspecs]] $msg + #arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs + } } #--------------------------------------------------------------------------------------------- @@ -5867,14 +6304,25 @@ tcl::namespace::eval punk::args { #set combined_defaults [tcl::dict::merge $VAL_DEFAULTS $OPT_DEFAULTS] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash #puts "---opts_and_values:$opts_and_values" #puts "---argstate:$argstate" + #JJJ api_argname e.g -increasing|-SORTOPTION tcl::dict::for {api_argname value_group} $opts_and_values { if {[string match -* $api_argname]} { - #get full option name such as -fg|-foreground from non-alias name such as -foreground - #if "@opts -any|-arbitrary true" - we may have an option that wasn't defined - if {[dict exists $lookup_optset $api_argname]} { - set argname [dict get $lookup_optset $api_argname] + if {[string first | $api_argname] > -1} { + #flag_ident style (grouped options with -parsekey) + lassign [split $api_argname |] f parsekey + if {[dict exists $lookup_optset $f]} { + set argname [dict get $lookup_optset $f] + } else { + puts stderr "punk::args::get_dict unable to find $f in $lookup_optset (parsekey:$parsekey) (value_group: $value_group)" + } } else { - puts stderr "unable to find $api_argname in $lookup_optset" + if {[dict exists $lookup_optset $api_argname]} { + #get full option name such as -fg|-foreground from non-alias name such as -foreground + #if "@opts -any|-arbitrary true" - we may have an option that wasn't defined + set argname [dict get $lookup_optset $api_argname] + } else { + puts stderr "punk::args::get_dict unable to find $api_argname in $lookup_optset (value_group: $value_group)" + } } } else { set argname $api_argname @@ -6615,10 +7063,31 @@ tcl::namespace::eval punk::args { } } - return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived multis $multisreceived] + set finalopts [dict create] + dict for {o v} $opts { + if {[string first | $o] > -1} { + dict set finalopts [lindex [split $o |] end] $v + } else { + dict set finalopts $o $v + } + } + return [tcl::dict::create leaders $leaders_dict opts $finalopts values $values_dict received $received_posns solos $solosreceived multis $multisreceived] } - + lappend PUNKARGS [list { + @id -id ::punk::args::forms + @cmd -name punk::args::forms\ + -summary\ + "List command forms."\ + -help\ + "Return names for each form of a command identified by 'id'. + Most commands are single-form and will only return the name '_default'." + @leaders -min 0 -max 0 + @opts + @values -min 1 -max 1 + id -multiple 0 -optional 0 -help\ + "Exact id of command" + }] proc forms {id} { set spec [get_spec $id] if {[dict size $spec]} { @@ -6629,13 +7098,17 @@ tcl::namespace::eval punk::args { } lappend PUNKARGS [list { @id -id ::punk::args::synopsis - @cmd -name punk::args::synopsis -help\ - "Return synopsis for each form of a command id + @cmd -name punk::args::synopsis\ + -summary\ + "Command synopsis"\ + -help\ + "Return synopsis for each form of a command on separate lines. If -form is given, supply only the synopsis for that form. " @opts + -noheader -type none -form -type string -default * -return -type string -default full -choices {full summary dict} @values -min 1 -max -1 @@ -6650,13 +7123,18 @@ tcl::namespace::eval punk::args { set has_punkansi 1 } if {$has_punkansi} { - set I [punk::ansi::a+ italic] - set NI [punk::ansi::a+ noitalic] + set I [punk::ansi::a+ italic] + set NI [punk::ansi::a+ noitalic] + #for inner question marks marking optional type + set IS [punk::ansi::a+ italic strike] + set NIS [punk::ansi::a+ noitalic nostrike] #set RST [punk::ansi::a] set RST "\x1b\[m" } else { set I "" set NI "" + set IS "" + set NIS "" set RST "" } @@ -6673,12 +7151,12 @@ tcl::namespace::eval punk::args { ##set id [lindex $arglist 0] ##set cmdargs [lrange $arglist 1 end] - lassign [dict values $argd] leaders opts values + lassign [dict values $argd] leaders opts values received set form [dict get $opts -form] set opt_return [dict get $opts -return] set cmditems [dict get $values cmditem] - set id [lindex $cmditems 0] - set cmdargs [lrange $cmditems 1 end] + set id [lindex $cmditems 0] + set cmdargs [lrange $cmditems 1 end] set spec [get_spec $id] @@ -6704,11 +7182,15 @@ tcl::namespace::eval punk::args { } set SYND [dict create] - set syn "" + dict set SYND cmd_info [dict get $spec cmd_info] + #leading "# " required (punk::ns::synopsis will pass through) + if {![dict exists $received -noheader]} { + set syn "# [Dict_getdef $spec cmd_info -summary ""]\n" + } #todo - -multiple etc foreach f $form_names { set SYNLIST [list] - dict set SYND $f [list] + dict set SYND FORMS $f [list] append syn "$id" set forminfo [dict get $spec FORMS $f] #foreach argname [dict get $forminfo LEADER_NAMES] { @@ -6731,6 +7213,7 @@ tcl::namespace::eval punk::args { # dict set ARGD display $display # dict lappend SYND $f $ARGD #} + set FORMARGS [list] foreach argname [dict get $forminfo LEADER_NAMES] { set arginfo [dict get $forminfo ARG_INFO $argname] set typelist [dict get $arginfo -type] @@ -6824,68 +7307,140 @@ tcl::namespace::eval punk::args { dict set ARGD type [dict get $arginfo -type] dict set ARGD optional [dict get $arginfo -optional] dict set ARGD display $display - dict lappend SYND $f $ARGD + + #dict lappend SYND $f $ARGD + lappend FORMARGS $ARGD } foreach argname [dict get $forminfo OPT_NAMES] { set arginfo [dict get $forminfo ARG_INFO $argname] set ARGD [dict create argname $argname class option] set tp [dict get $arginfo -type] - if {[dict exists $arginfo -typesynopsis]} { - set tp_display [dict get $arginfo -typesynopsis] + if {$tp eq "none"} { + #assert - argname may have aliases delimited by | - but no aliases end with = + #(disallowed in punk::args::define) + set argdisplay $argname } else { - #set tp_display "<$tp>" - set alternates [list];#alternate acceptable types e.g literal(yes)|literal(ok) or indexpression|literal(first) - foreach tp_member [split $tp |] { - #-type literal not valid for opt - review - if {[string match literal(*) $tp_member]} { - set match [string range $tp_member 8 end-1] - lappend alternates $match - } elseif {[string match literalprefix(*) $tp_member]} { - set match [string range $tp_member 14 end-1] - lappend alternates $match + #assert [llength $tp] == 1 (multiple values for flag unspported in punk::args::define) + if {[string match {\?*\?} $tp]} { + set tp [string range $tp 1 end-1] + set value_is_optional true + } else { + set value_is_optional false + } + + + if {[dict exists $arginfo -typesynopsis]} { + set tp_display [dict get $arginfo -typesynopsis] + #user may or may not have remembered to match the typesynopsis with the optionality by wrapping with ? + #review - if user wrapped with ?*? and also leading/trailing ANSI - we won't properly strip + #todo - enforce no wrapping '?*?' in define for -typesynopsis? + set tp_display [string trim $tp_display ?] + } else { + + set alternates [list];#alternate acceptable types e.g literal(yes)|literal(ok) or indexpression|literal(first) + foreach tp_member [split $tp |] { + #-type literal not valid for opt - review + if {[string match literal(*) $tp_member]} { + set match [string range $tp_member 8 end-1] + lappend alternates $match + } elseif {[string match literalprefix(*) $tp_member]} { + set match [string range $tp_member 14 end-1] + lappend alternates $match + } else { + lappend alternates <$I$tp_member$NI> + } + } + #todo - trie prefixes display? + set alternates [punk::args::lib::lunique $alternates] + set tp_display [join $alternates |] + } + if {[string first | $tp_display] >=0} { + #need to bracket alternate-types to distinguish pipes delimiting flag aliases + set tp_display "($tp_display)" + } + set argdisplay "" + foreach aliasflag [split $argname |] { + if {[string match --* $aliasflag]} { + if {[string index $aliasflag end] eq "="} { + set alias [string range $aliasflag 0 end-1] + if {$value_is_optional} { + append argdisplay "$alias$IS?$NIS=$tp_display$IS?$NIS|" + } else { + append argdisplay "$alias=$tp_display|" + } + } else { + if {$value_is_optional} { + append argdisplay "$aliasflag $IS?$NIS$tp_display$IS?$NIS|" + } else { + append argdisplay "$aliasflag $tp_display|" + } + } } else { - lappend alternates $I<$tp_member>$NI + if {$value_is_optional} { + #single dash flag can't accept optional value + append argdisplay "$aliasflag|" + } else { + append argdisplay "$aliasflag $tp_display|" + } } } - #todo - trie prefixes display? - set alternates [punk::args::lib::lunique $alternates] - set tp_display [join $alternates |] + set argdisplay [string trimright $argdisplay |] } if {[dict get $arginfo -optional]} { if {[dict get $arginfo -multiple]} { - if {$tp eq "none"} { - set display "?$argname?..." - } else { - set display "?$argname $tp_display?..." - } + set display "?$argdisplay?..." } else { - if {$tp eq "none"} { - set display "?$argname?" - } else { - set display "?$argname $tp_display?" - } + set display "?$argdisplay?" } } else { if {[dict get $arginfo -multiple]} { - if {$tp eq "none"} { - set display "$argname ?$argname...?" - } else { - set display "$argname $tp_display ?$argname $tp_display?..." - } + set display "$argdisplay ?$argdisplay?..." } else { - if {$tp eq "none"} { - set display $argname - } else { - set display "$argname $tp_display" - } + set display $argdisplay } } + + #if {[string index $argname end] eq "="} { + # set __ "" + #} else { + # set __ " " + #} + #if {[dict get $arginfo -optional]} { + # if {[dict get $arginfo -multiple]} { + # if {$tp eq "none"} { + # set display "?$argname?..." + # } else { + # set display "?$argname$__$tp_display?..." + # } + # } else { + # if {$tp eq "none"} { + # set display "?$argname?" + # } else { + # set display "?$argname$__$tp_display?" + # } + # } + #} else { + # if {[dict get $arginfo -multiple]} { + # if {$tp eq "none"} { + # set display "$argname ?$argname...?" + # } else { + # set display "$argname$__$tp_display ?$argname$__$tp_display?..." + # } + # } else { + # if {$tp eq "none"} { + # set display $argname + # } else { + # set display "$argname$__$tp_display" + # } + # } + #} append syn " $display" dict set ARGD type [dict get $arginfo -type] dict set ARGD optional [dict get $arginfo -optional] dict set ARGD display $display - dict lappend SYND $f $ARGD + #dict lappend SYND $f $ARGD + lappend FORMARGS $ARGD } foreach argname [dict get $forminfo VAL_NAMES] { set arginfo [dict get $forminfo ARG_INFO $argname] @@ -6999,9 +7554,11 @@ tcl::namespace::eval punk::args { dict set ARGD type [dict get $arginfo -type] dict set ARGD optional [dict get $arginfo -optional] dict set ARGD display $display - dict lappend SYND $f $ARGD + #dict lappend SYND $f $ARGD + lappend FORMARGS $ARGD } append syn \n + dict set SYND FORMS $f $FORMARGS } switch -- $opt_return { full { @@ -7009,8 +7566,8 @@ tcl::namespace::eval punk::args { } summary { set summary "" - showdict $SYND - dict for {form arglist} $SYND { + set FORMS [dict get $SYND FORMS] + dict for {form arglist} $FORMS { append summary $id set class_state leader set option_count 0 @@ -7218,7 +7775,10 @@ tcl::namespace::eval punk::args::lib { #e.g tstr -allowcommands {This is the value of [lindex $x -1] in calling scope ${[lindex [set x] 0]} !} lappend PUNKARGS [list { @id -id ::punk::args::lib::tstr - @cmd -name punk::args::lib::tstr -help\ + @cmd -name punk::args::lib::tstr\ + -summary\ + "Templating with \$\{$varName\}"\ + -help\ "A rough equivalent of js template literals Substitutions: diff --git a/src/modules/punk/args-buildversion.txt b/src/modules/punk/args-buildversion.txt index 5c2f18b2..ad438736 100644 --- a/src/modules/punk/args-buildversion.txt +++ b/src/modules/punk/args-buildversion.txt @@ -1,3 +1,3 @@ -0.1.9 +0.2 #First line must be a semantic version number #all other lines are ignored. diff --git a/src/modules/punk/args/tclcore-999999.0a1.0.tm b/src/modules/punk/args/tclcore-999999.0a1.0.tm index df821da9..5c4ce089 100644 --- a/src/modules/punk/args/tclcore-999999.0a1.0.tm +++ b/src/modules/punk/args/tclcore-999999.0a1.0.tm @@ -656,7 +656,61 @@ tcl::namespace::eval punk::args::tclcore { channel -help \ "" } "@doc -name Manpage: -url [manpage_tcl chan]" ] - #close + + lappend PUNKARGS [list { + @id -id ::tcl::chan::close + @cmd -name "Builtin: tcl::chan::close" -help\ + "Close and destroy the channel called channel. Note that this deletes all existing file-events + registered on the channel. If the direction argument (which must be read or write or any + unique abbreviation of them) is present, the channel will only be half-closed, so that it can + go from being read-write to write-only or read-only respectively. If a read-only channel is + closed for reading, it is the same as if the channel is fully closed, and respectively similar + for write-only channels. Without the direction argument, the channel is closed for both reading + and writing (but only if those directions are currently open). It is an error to close a + read-only channel for writing, or a write-only channel for reading. + As part of closing the channel, all buffered output is flushed to the channel's output device + (only if the channel is ceasing to be writable), any buffered input is discarded (only if the + channel is ceasing to be readable), the underlying operating system resource is closed and + channel becomes unavailable for future use (both only if the channel is being completely closed). + + If the channel is blocking and the channel is ceasing to be writable, the command does not return + until all output is flushed. If the channel is non-blocking and there is unflushed output, the + channel remains open and the command returns immediately; output will be flushed in the + background and the channel will be closed when all the flushing is complete. + + If channel is a blocking channel for a command pipeline then chan close waits for the child + processes to complete. + + If the channel is shared between interpreters, then chan close makes channel unavailable in the + invoking interpreter but has no other effect until all of the sharing interpreters have closed the + channel. When the last interpreter in which the channel is registered invokes chan close (or close), + the cleanup actions described above occur. With half-closing, the half-close of the channel only + applies to the current interpreter's view of the channel until all channels have closed it in that + direction (or completely). See the interp command for a description of channel sharing. + + Channels are automatically fully closed when an interpreter is destroyed and when the process exits. + Channels are switched to blocking mode, to ensure that all output is correctly flushed before the + process exits. + + The command returns an empty string, and may generate an error if an error occurs while flushing + output. If a command in a command pipeline created with open returns an error, chan close generates + an error (similar to the exec command.) + + Note that half-closes of sockets and command pipelines can have important side effects because they + result in a shutdown() or close() of the underlying system resource, which can change how other + processes or systems respond to the Tcl program. + + Channels are automatically closed when an interpreter is destroyed and when the process exits. + From 8.6 on (TIP#398), nonblocking channels are no longer switched to blocking mode when exiting; + this guarantees a timely exit even when the peer or a communication channel is stalled. To ensure + proper flushing of stalled nonblocking channels on exit, one must now either (a) actively switch + them back to blocking or (b) use the environment variable TCL_FLUSH_NONBLOCKING_ON_EXIT, which when + set and not equal to “0” restores the previous behavior." + @values -min 1 -max 1 + channel + direction -optional 1 -choices {read write} + } "@doc -name Manpage: -url [manpage_tcl chan]" ] + lappend PUNKARGS [list { @id -id ::fconfigure @cmd -name "Builtin: chan configure" -help\ @@ -686,9 +740,20 @@ tcl::namespace::eval punk::args::tclcore { application must be using the Tcl event loop (e.g. by calling ${$B}Tcl_DoOneEvent${$N} or invoking the ${$B}vwait${$N} command). ${$B}-buffering${$N} ${$I}newValue${$NI} - + If ${$I}newValue${$NI} is ${$B}full${$N} then the I/O system will buffer output until its + internal buffer is full or until the ${$B}chan flush${$N} command is invoked. If + ${$I}newValue${$NI} is ${$B}line${$N}, then the I/O system will automatically flush output for + the channel whenever a newline character is output. If ${$I}newValue${$NI} is ${$B}none${$N}, + the I/O system will flush automatically after every output operation. The + default is for ${$B}-buffering${$N} to be set to ${$B}full${$N} except for channels that + connect to terminal-like devices; for these channels the initial setting + is ${$B}line${$N}. Additionally, ${$B}stdin${$N} and ${$B}stdout${$N} are initially set to ${$B}line${$N}, and + ${$B}stderr${$N} is set to ${$B}none${$N}. ${$B}-buffersize${$N} ${$I}newSize${$NI} - + ${$I}newSize${$NI} must be an integer; its value is used to set the size of buffers, + in bytes, subsequently allocated for this channel to store input or output. + ${$I}newSize${$NI} must be a number of no more than one million, allowing buffers of + up to one million bytes in size. ${$B}-encoding${$N} ${$I}name${$NI} ${$B}-eofchar${$N} ${$I}char${$NI} @@ -716,7 +781,10 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @id -id ::tcl::chan::eof - @cmd -name "Builtin: tcl::chan::eof" -help\ + @cmd -name "Builtin: tcl::chan::eof"\ + -summary\ + "Check for end of file condition on channel"\ + -help\ "Test whether the last input operation on the channel called ${$I}channel${$NI} failed because the end of the data stream was reached, returning 1 if end-of-file was reached, and 0 otherwise." @@ -726,14 +794,69 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl chan]" ] #event - #flush - #gets + lappend PUNKARGS [list { + @id -id ::tcl::chan::flush + @cmd -name "Builtin: tcl::chan::flush"\ + -summary\ + "Flush pending output."\ + -help\ + "Ensures that all pending output for the channel called channel is written. + If the channel is in blocking mode the command does not return until all the buffered output + has been flushed to the channel. If the channel is in non-blocking mode, the command may + return before all buffered output has been flushed; the remainder will be flushed in the + background as fast as the underlying file or device is able to absorb it." + @values -min 1 -max 1 + channel + } "@doc -name Manpage: -url [manpage_tcl chan]" ] + + lappend PUNKARGS [list { + @id -id ::tcl::chan::gets + @cmd -name "Builtin: tcl::chan::gets"\ + -summary\ + "Read a line from channel."\ + -help\ + "Reads a line from the channel consisting of all characters up to the next end-of-line sequence + or until end of file is seen. The line feed character corresponding to end-of-line sequence is + not included as part of the line. If the varName argument is specified, the line is stored in + the variable of that name and the command returns the length of the line. If varName is not + specified, the command returns the line itself as the result of the command. + If a complete line is not available and the channel is not at EOF, the command will block in the + case of a blocking channel. For non-blocking channels, the command will return the empty string + as the result in the case of varName not specified and -1 if it is. + + If a blocking channel is already at EOF, the command returns an empty string if varName is not + specified. Note an empty string result can also be returned when a blank line (no characters + before the next end of line sequence). The two cases can be distinguished by calling the chan eof + command to check for end of file. If varName is specified, the command returns -1 on end of file. + There is no ambiguity in this case because blank lines result in 0 being returned. + + If a non-blocking channel is already at EOF, the command returns an empty line if varName is not + specified. This can be distinguished from an empty line being returned by either a blank line + being read or a full line not being available through the use of the chan eof and chan blocked + commands. If chan eof returns true, the channel is at EOF. If chan blocked returns true, a full + line was not available. If both commands return false, an empty line was read. If varName was + specified for a non-bocking channel at EOF, the command returns -1. This can be distinguished + from full line not being available either by chan eof or chan blocked as above. Note that when + varName is specified, there is no need to distinguish between eof and blank lines as the latter + will result in the command returning 0. + + If the encoding profile strict is in effect for the channel, the command will raise an exception + with the POSIX error code EILSEQ if any encoding errors are encountered in the channel input data. + The file pointer remains unchanged and it is possible to introspect, and in some cases recover, by + changing the encoding in use" + @values -min 1 -max 2 + channel + varName -optional 1 + } "@doc -name Manpage: -url [manpage_tcl chan]" ] #isbinary #names #pending lappend PUNKARGS [list { @id -id ::tcl::chan::pipe - @cmd -name "Builtin: tcl::chan::pipe" -help\ + @cmd -name "Builtin: tcl::chan::pipe"\ + -summary\ + "Create a standalone pipe."\ + -help\ "Creates a standalone pipe whose read- and write-side channels are returned as a 2-element list, the first element being the read side and the second write side. Can be useful e.g. to redirect separately ${$B}stderr${$N} and ${$B}stdout${$N} @@ -753,13 +876,113 @@ tcl::namespace::eval punk::args::tclcore { @values -min 0 -max 0 } "@doc -name Manpage: -url [manpage_tcl chan]" ] + lappend PUNKARGS [list { + @id -id ::tcl::chan::pop + @cmd -name "Builtin: tcl::chan::pop"\ + -summary\ + "Remove topmost channel transform."\ + -help\ + "Removes the topmost transformation from the channel ${$I}channel${$NI}, if there is any. + If there are no transformations added to channel, this is equivalent to + ${$B}chan${$N} close of that channel. The result is normally the empty string, but can + be an error in some situations (i.e. where the underlying system stream is + closed and that results in an error)." + @values -min 1 -max 1 + channel -type string + } "@doc -name Manpage: -url [manpage_tcl chan]" ] + lappend PUNKARGS [list { + @id -id ::tcl::chan::puts + @cmd -name "Builtin: tcl::chan::puts"\ + -summary\ + "Write to a channel."\ + -help\ + "Writes ${$I}string${$NI} to the channel named ${$I}channel${$NI} followed by a newline character. A + trailing newline character is written unless the optional flag ${$B}-nonewline${$N} is + given. If channel is omitted, the string is written to the standard output + channel, ${$B}stdout${$N}. + Newline characters in the output are translated by ${$B}chan puts${$N} to platform-specific + end-of-line sequences according to the currently configured value of the + ${$B}-translation${$N} option for the channel (for example, on PCs newlines are normally + replaced with carriage-return-linefeed sequences; see ${$B}chan configure${$N} for details). + + Tcl buffers output internally, so characters written with ${$B}chan puts${$N} may not appear + immediately on the output file or device; Tcl will normally delay output until the + buffer is full or the channel is closed. You can force output to appear + immediately with the ${$B}chan flush${$N} command. + + When the output buffer fills up, the ${$B}chan puts${$N} command will normally block until + all the buffered data has been accepted for output by the operating system. If + channel is in non-blocking mode then the ${$B}chan puts${$N} command will not block even if + the operating system cannot accept the data. Instead, Tcl continues to buffer the + data and writes it in the background as fast as the underlying file or device can + accept it. The application must use the Tcl event loop for non-blocking output to + work; otherwise Tcl never finds out that the file or device is ready for more + output data. It is possible for an arbitrarily large amount of data to be buffered + for a channel in non-blocking mode, which could consume a large amount of memory. + To avoid wasting memory, non-blocking I/O should normally be used in an + event-driven fashion with the ${$B}chan event${$N} command (do not invoke ${$B}chan puts${$N} unless + you have recently been notified via a file event that the channel is ready for more + output data). + + The command will raise an error exception with POSIX error code ${$B}EILSEQ${$N} if the + encoding profile ${$B}strict${$N} is in effect for the channel and the output data cannot be + encoded in the encoding configured for the channel. Data may be partially written + to the channel in this case." + @opts -prefix 0 + -nonewline -type none + @values -min 1 -max 2 + channel -type string -optional 1 + string -type string + } "@doc -name Manpage: -url [manpage_tcl chan]" ] } + lappend PUNKARGS [list { + @id -id ::tcl::chan::seek + @cmd -name "Builtin: tcl::chan::seek"\ + -summary\ + "Set channel access position as byte offset."\ + -help\ + "Sets the current access position within the underlying data stream for the channel named + channel to be offset bytes relative to origin. + Offset must be an integer (which may be negative) + The origin argument defaults to start. + + Chan seek flushes all buffered output for the channel before the command returns, even if the + channel is in non-blocking mode. It also discards any buffered and unread input. This command + returns an empty string. An error occurs if this command is applied to channels whose + underlying file or device does not support seeking. + + Note that offset values are byte offsets, not character offsets. Both chan seek and chan tell + operate in terms of bytes, not characters, unlike chan read." + @values -min 2 -max 3 + channel + offset -type integer + origin -type string\ + -default start\ + -optional 1\ + -choicecolumns 1\ + -choices {start current end}\ + -choicelabels { + start\ + " The new access position will be offset bytes from the start of the underlying file or device." + current\ + " The new access position will be offset bytes from the current access position; a negative + offset moves the access position backwards in the underlying file or device." + enc\ + " The new access position will be offset bytes from the end of the file or device. A negative + 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]" ] + lappend PUNKARGS [list { @id -id ::tcl::chan::tell - @cmd -name "Builtin: tcl::chan::tell" -help\ + @cmd -name "Builtin: tcl::chan::tell"\ + -summary\ + "Report channel access position as byte offset."\ + -help\ "Returns a number giving the current access position within the underlying data stream for the channel named channel. This value returned is a byte offset that can be passed to ${[a+ bold]}chan seek${[a+ normal]} in order @@ -774,7 +997,10 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @id -id ::tcl::chan::truncate - @cmd -name "Builtin: tcl::chan::truncate" -help\ + @cmd -name "Builtin: tcl::chan::truncate"\ + -summary\ + "Truncate channel to specified length or current byte offset."\ + -help\ "Sets the byte length of the underlying data stream for the channel to be length (or to the current byte offset within the underlying data stream if length is omitted). The channel is flushed before truncation." @@ -1502,8 +1728,17 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { #test of @form @id -id ::after - @cmd -name "Builtin: after" -help\ - "Execute a command after a time delay." + @cmd -name "Builtin: after"\ + -summary\ + "Execute a command after a time delay."\ + -help\ + "This command is used to delay execution of the program or to execute a + command in background sometime in the future. + The after ms and after idle forms of the command assume that the application + is event driven: the delayed commands will not be executed unless the + application enters the event loop. In applications that are not normally + event-driven, such as tclsh, the event loop can be entered with the vwait + and update commands." # ---------- shared elements ------------- @ref -id common_script_help -help\ @@ -1561,12 +1796,15 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl after]" ] namespace eval argdoc { + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @dynamic @id -id ::append - @cmd -name "Builtin: append" -help\ - "Append to variable - Append al of the ${$I}value${$NI} arguments to the current value of variable + @cmd -name "Builtin: append"\ + -summary\ + "Append to variable."\ + -help\ + "Append all of the ${$I}value${$NI} arguments to the current value of variable ${$I}varName${$NI}. if ${$I}varName${$NI} does not exist, it is given a value equal to the concatenation of all the ${$I}value${$NI} arguments. if ${$I}varName indicates an element that does not exist of an array that has a default value @@ -1581,14 +1819,74 @@ tcl::namespace::eval punk::args::tclcore { value -type string -optional 1 -multiple 1 } "@doc -name Manpage: -url [manpage_tcl append]" ] - } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::apply + @cmd -name "Builtin: apply"\ + -summary\ + {Apply an anonymous function.}\ + -help\ + {The command ${$B}apply${$N} applies the function ${$I}func${$NI} to the arguments arg1 arg2 ... + and returns the result. + The function func is a two element list {${$I}args body${$NI}} or a three element list + {${$I}args body namespace${$NI}} (as if the list command had been used). The first + element ${$I}args${$NI} specifies the formal arguments to func. The specification of + the formal arguments ${$I}args${$NI} is shared with the ${$B}proc${$N} command, and is described + in detail in the corresponding manual page. + + The contents of ${$I}body${$NI} are executed by the Tcl interpreter after the local + variables corresponding to the formal arguments are given the values of the + actual parameters arg1 arg2 .... When ${$I}body${$NI} is being executed, variable names + normally refer to local variables, which are created automatically when + referenced and deleted when ${$B}apply${$N} returns. One local variable is automatically + created for each of the function's arguments. Global variables can only be + accessed by invoking the ${$B}global${$N} command or the ${$B}upvar${$N} command. Namespace + variables can only be accessed by invoking the ${$B}variable${$N} command or the ${$B}upvar${$N} + command. + + The invocation of ${$B}apply${$N} adds a call frame to Tcl's evaluation stack (the stack + of frames accessed via ${$B}uplevel${$N}). The execution of ${$I}body${$NI} proceeds in this call + frame, in the namespace given by ${$I}namespace${$NI} or in the global namespace if none + was specified. If given, ${$I}namespace${$NI} is interpreted relative to the global + namespace even if its name does not start with “::”. + + The semantics of ${$B}apply${$N} can also be described by approximately this: + ${[punk::args::tclcore::argdoc::example { + proc apply {fun args} { + set len [llength $fun] + if {($len < 2) || ($len > 3)} { + error "can't interpret \"$fun\" as anonymous function" + } + lassign $fun argList body ns + set name ::$ns::[getGloballyUniqueName] + set body0 { + rename [lindex [info level 0] 0] {} + } + proc $name $argList ${body0}$body + set code [catch {uplevel 1 $name $args} res opt] + return -options $opt $res + }}]} + } + + @values -min 1 + "{args body ?namespace?}" -optional 0 -type list -minsize 2 -maxsize 3 + arg -type any -optional 1 -multiple 1 + + + } "@doc -name Manpage: -url [manpage_tcl append]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - namespace eval argdoc { lappend PUNKARGS [list { @dynamic @id -id ::array - @cmd -name "Builtin: array" -help\ - "Manipulate array variables" + @cmd -name "Builtin: array"\ + -summary\ + "Manipulate array variables"\ + -help\ + "This command performs one of several operations on the variable given by + arrayName. Unless otherwise specified for individual commands below, + arrayName must be the name of an existing array variable. The subcommand + argument determines what action is carried out by the command." @leaders ${[punk::args::tclcore::argdoc::array_subcommands]} @@ -1598,9 +1896,11 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @id -id ::tcl::array::default - @cmd -name "Builtin: array default" -help\ - "Manages the default value of the array. - Arrays initially have no default value, but this command allows you to set one; + @cmd -name "Builtin: array default"\ + -summary\ + "Manages the default value of the array."\ + -help\ + "Arrays initially have no default value, but this command allows you to set one; the default value will be returned when reading from an element of the array ${$I}arrayName${$NI} if the read would otherwise result in an error. Note that this may cause the ${$B}append${$N}, ${$B}dict${$N}, ${$B}incr${$N} and ${$B}lappend${$N} @@ -1658,9 +1958,11 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::break - @cmd -name "Builtin: break" -help\ - "Abort looping command. - This command is typically invoked inside the body of a looping command such + @cmd -name "Builtin: break"\ + -summary\ + "Abort looping command"\ + -help\ + "This command is typically invoked inside the body of a looping command such as ${$B}for${$N} or ${$B}foreach${$N} or ${$B}while${$N}. It returns a 3 (${$B}TCL_BREAK${$N}) result code, which causes a break exception to occur. The exception causes the current script to be aborted out to the @@ -1674,11 +1976,107 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { - @id -id ::const - @cmd -name "Builtin: const" -help\ - "Create and initialise a constant. + @id -id ::catch + @cmd -name "Builtin: catch"\ + -summary\ + "Evaluate script and trap exceptional returns."\ + -help\ + "The catch command may be used to prevent errors from aborting command + interpretation. The catch command calls the Tcl interpreter recursively to + execute script, and always returns without raising an error, regardless of + any errors that might occur while executing script. + If script raises an error, catch will return a non-zero integer value + corresponding to the exceptional return code returned by evaluation of + script. Tcl defines the normal return code from script evaluation to be + zero (0), or TCL_OK. Tcl also defines four exceptional return codes: + 1 (TCL_ERROR), 2 (TCL_RETURN), 3 (TCL_BREAK), and 4 (TCL_CONTINUE). + Errors during evaluation of a script are indicated by a return code of + TCL_ERROR. The other exceptional return codes are returned by the return, + break, and continue commands and in other special situations as documented. + New commands defined by Tcl packages as well as scripts that make use of the + return -code command can return other integer values as the return code. + These must however lie outside the range reserved for Tcl as documented for + the return command. + + If the resultVarName argument is given, then the variable it names is set to + the result of the script evaluation. When the return code from the script is + 1 (TCL_ERROR), the value stored in resultVarName is an error message. When + the return code from the script is 0 (TCL_OK), the value stored in + resultVarName is the value returned from script. + + If the optionsVarName argument is given, then the variable it names is set to + a dictionary of return options returned by evaluation of script. Tcl specifies + two entries that are always defined in the dictionary: -code and -level. When + the return code from evaluation of script is not TCL_RETURN, the value of the + -level entry will be 0, and the value of the -code entry will be the same as + the return code. Only when the return code is TCL_RETURN will the values of + the -level and -code entries be something else, as further described in the + documentation for the return command. + + When the return code from evaluation of script is TCL_ERROR, four additional + entries are defined in the dictionary of return options stored in optionsVarName: + -errorinfo, -errorcode, -errorline, and -errorstack. The value of the -errorinfo + entry is a formatted stack trace containing more information about the context in + which the error happened. The formatted stack trace is meant to be read by a + person. The value of the -errorcode entry is additional information about the + error stored as a list. The -errorcode value is meant to be further processed by + programs, and may not be particularly readable by people. The value of the + -errorline entry is an integer indicating which line of script was being + evaluated when the error occurred. The value of the -errorstack entry is an + even-sized list made of token-parameter pairs accumulated while unwinding the + stack. The token may be “CALL”, in which case the parameter is a list made of the + proc name and arguments at the corresponding level; or it may be “UP”, in which + case the parameter is the relative level (as in uplevel) of the previous CALL. + The salient differences with respect to -errorinfo are that: + + + 1. it is a machine-readable form that is amenable to processing with + [foreach {tok prm} ...], + 2. it contains the true (substituted) values passed to the functions, instead of + the static text of the calling sites, and + 3. it is coarser-grained, with only one element per stack frame (like procs; + no separate elements for foreach constructs for example). + + The values of the -errorinfo and -errorcode entries of the most recent error are + also available as values of the global variables ::errorInfo and ::errorCode + respectively. The value of the -errorstack entry surfaces as info errorstack. + + Tcl packages may provide commands that set other entries in the dictionary of + return options, and the return command may be used by scripts to set return options + in addition to those defined above." + @values -min 1 -max 3 + script + resultVarName -type string -optional 1 + optionsVarName -type string -optional 1 + + } "@doc -name Manpage: -url [manpage_tcl catch]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @dynamic + @id -id ::concat + @cmd -name "Builtin: concat"\ + -summary\ + "Join lists together."\ + -help\ + "This command joins each of its arguments together with spaces after trimming + leading and trailing white-space from each of them. If all of the arguments + are lists, this has the same effect as concatenating them into a single list. + Arguments that are empty (after trimming) are ignored entirely. It permits + any number of arguments; if no args are supplied, the result is an empty + string." + @values -min 0 + arg -type string -optional 1 -multiple 1 -help\ + "Usually, but not necessarily a proper Tcl list" + } "@doc -name Manpage: -url [manpage_tcl concat]" ] - This command is normally used within a procedure body (or method body, + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::const + @cmd -name "Builtin: const"\ + -summary\ + "Create and initialise a constant."\ + -help\ + "This command is normally used within a procedure body (or method body, or lambda term) to create a constant within that procedure, or within a namespace eval body to create a constant within that namespace. The constant is an unmodifiable variable, called varName, that is initialised @@ -1703,9 +2101,11 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::continue - @cmd -name "Builtin: continue" -help\ - "Skip to the next iteration of a loop. - This command is typically invoked inside the body of a looping command such + @cmd -name "Builtin: continue"\ + -summary\ + "Skip to the next iteration of a loop."\ + -help\ + "This command is typically invoked inside the body of a looping command such as ${$B}for${$N} or ${$B}foreach${$N} or ${$B}while${$N}. It returns a 4 (${$B}TCL_CONTINUE${$N}) result code, which causes a continue exception to occur. The exception causes the current script to be aborted out to the @@ -1715,12 +2115,76 @@ tcl::namespace::eval punk::args::tclcore { procedure bodies." @values -min 0 -max 0 } "@doc -name Manpage: -url [manpage_tcl continue]" ] + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::eof + @cmd -name "Builtin: eof"\ + -summary\ + "Check for end of file condition on channel"\ + -help\ + "Test whether the last input operation on the channel called ${$I}channel${$NI} + failed because the end of the data stream was reached, returning 1 if end-of-file + was reached, and 0 otherwise. + + The ${$B}eof${$N} command has been superceded by the ${$B}chan eof${$N} command + which supports the same syntax and options." + @values -min 1 -max 1 + channel -help \ + "" + } "@doc -name Manpage: -url [manpage_tcl eof]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::error + @cmd -name "Builtin: error"\ + -summary\ + "Generate an error."\ + -help\ + "Returns a TCL_ERROR code, which causes command interpretation to be unwound. + Message is a string that is returned to the application to indicate what went + wrong. + The -errorinfo return option of an interpreter is used to accumulate a stack + trace of what was in progress when an error occurred; as nested commands + unwind, the Tcl interpreter adds information to the -errorinfo return option. + If the info argument is present, it is used to initialize the -errorinfo + return options and the first increment of unwind information will not be added + by the Tcl interpreter. In other words, the command containing the error + command will not appear in the stack trace; in its place will be info. + Historically, this feature had been most useful in conjunction with the catch + command: if a caught error cannot be handled successfully, info can be used to + return a stack trace reflecting the original point of occurrence of the error: + ${[punk::args::tclcore::argdoc::example { + catch {...} errMsg + set savedInfo $::errorInfo + ... + error $errMsg $savedInfo + }]} + When working with Tcl 8.5 or later, the following code should be used intead: + ${[punk::args::tclcore::argdoc::example { + catch {...} errMsg options + ... + return -options $options $errMsg + }]} + If the code argument is present, then its value is stored in the -errorcode + return option. The -errorcode return option is intended to hold a + machine-readable description of the error in cases where such information is + available; see the return manual page for information on the proper format for + this option's value." + @values -min 1 -max 3 + message -type string + info -type string -optional 1 + code -type list -optional 1 -help\ + "machine-readable data to store in -errorcode return option" + + } "@doc -name Manpage: -url [manpage_tcl error]" ] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::exec - @cmd -name "Builtin: exec" -help\ - "Invoke subprocesses. - This command treats its arguments as the specification of one or more + @cmd -name "Builtin: exec"\ + -summary\ + "Invoke subprocesses."\ + -help\ + "This command treats its arguments as the specification of one or more subprocesses to execute. The arguments take the form of a standard shell pipeline where each arg becomes one word of a command, and each distinct command becomes a subprocess. The result of the command is the standard @@ -1756,9 +2220,11 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::expr - @cmd -name "Builtin: expr" -help\ - "Evaluate an expression. - Concatenates ${$I}args${$NI}, separated by a space, into an expression, + @cmd -name "Builtin: expr"\ + -summary\ + "Evaluate an expression."\ + -help\ + "Concatenates ${$I}args${$NI}, separated by a space, into an expression, and evaluates that expression, returning its value. The operators permitted in an expression include a subset of the operators permitted in C expressions. For those operators common to both Tcl and C, Tcl applies the same meaning and @@ -1783,7 +2249,10 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::for - @cmd -name "Builtin: for" -help\ + @cmd -name "Builtin: for"\ + -summary\ + "'For' loop"\ + -help\ "${$B}For${$N} is a looping command, simliar in structure to the C ${$B}for${$N} statement. The ${$I}start${$NI}, ${$I}next${$NI}, and ${$I}body${$NI} arguments must be Tcl command strings, and ${$I}test${$NI} is an expression string. The @@ -1819,7 +2288,10 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::foreach - @cmd -name "Builtin: foreach" -help\ + @cmd -name "Builtin: foreach"\ + -summary\ + "Iterate over all elements in one or more lists."\ + -help\ "The ${$B}foreach${$N} command implements a loop where the loop variable(s) take on values from one or more lists. In the simplest case there is one loop variable, ${$I}varname${$NI} and one list, ${$I}list${$NI}, that is a list of values @@ -1849,9 +2321,11 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::glob - @cmd -name "Builtin: glob" -help\ - "Return names of files that match patterns. - This command performs file name “globbing” in a fashion similar to the csh shell or bash shell. + @cmd -name "Builtin: glob"\ + -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. 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." @opts @@ -1936,6 +2410,24 @@ tcl::namespace::eval punk::args::tclcore { or [] construct." } "@doc -name Manpage: -url [manpage_tcl glob]" ] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::global + @cmd -name "Builtin: global"\ + -summary\ + "Access global variables from procs."\ + -help\ + "This command has no effect unless executed in the context of a proc body. If the ${$B}global${$N} command is executed + in the context of a proc body, it creates local variables linked to the corresponding global variables (though + these linked variables, like those created by ${$B}upvar${$N}, are not included in the list returned by ${$B}info locals${$N}). + If ${$I}varname${$NI} contains namespace qualifiers, the local variable's name is the unqualified name of the global + variable, as determined by the ${$B}namespace tail${$N} command. + + ${$I}varname${$NI} is always treated as the name of a variable, not an array element. An error is returned if the name + 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]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- } ############################################################################################################################################################ @@ -1951,9 +2443,11 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::if - @cmd -name "builtin: if" -help\ - "Execute scripts conditionally. - The ${$B}if${$N} command evaluates ${$I}expr1${$NI} as an expression (in the + @cmd -name "builtin: if"\ + -summary\ + "Execute scripts conditionally."\ + -help\ + "The ${$B}if${$N} command evaluates ${$I}expr1${$NI} as an expression (in the same way that ${$B}expr${$N} evaluates its argument). The value of the expression must be a boolean (a numeric value, where 0 is false and anything is true, or a string value such as ${$B}true${$N} or ${$B}yes${$N} for true @@ -1981,12 +2475,53 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl if]"] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::incr + @cmd -name "builtin: incr"\ + -summary\ + "Increment the value of a variable."\ + -help\ + "Increments the value stored in the variable whose name is ${$I}varName${$NI}. The + value of the variable must be an integer. If ${$I}increment${$NI} is supplied then + its value (which must be an integer) is added to the value of variable + ${$I}varName${$NI}; otherwise 1 is added to ${$I}varName${$NI}. The new value is stored as a + decimal string in variable ${$I}varName${$NI} and also returned as result. + Starting with the Tcl 8.5 release, the variable ${$I}varName${$NI} passed to ${$B}incr${$N} + may be unset, and in that case, it will be set to the value ${$I}increment${$NI} or + to the default increment value of ${$B}1${$N}. If ${$I}varName${$NI} indicates an element that + does not exist of an array that has a default value set, the sum of the + default value and the ${$I}increment${$NI} (or 1) will be stored in the array element." + @leaders -min 0 -max 0 + @values -min 1 -max 2 + varName -type string + increment -type integer -optional 1 + } "@doc -name Manpage: -url [manpage_tcl incr]"] + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @dynamic + @id -id ::join + @cmd -name "Builtin: join"\ + -summary\ + "Create a string by joining together list elements."\ + -help\ + "The ${$I}list${$NI} argument must be a valid Tcl list. This command returns the string + formed by joining all of the elements of ${$I}list${$NI} together with ${$I}joinString${$NI} + separating each adjacent pair of elements. The ${$I}joinString${$NI} argument defaults + to a space character." + @values -min 1 + list -type list + joinString -type string -default " " -optional 1 + + } "@doc -name Manpage: -url [manpage_tcl concat]" ] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::lappend - @cmd -name "builtin: lappend" -help\ - "Append list elements onto a variable. - This command treats the variable given by ${$I}listVar${$NI} as a list and + @cmd -name "builtin: lappend"\ + -summary\ + "Append list elements onto a variable."\ + -help\ + "This command treats the variable given by ${$I}listVar${$NI} as a list and appends each of the ${$I}value${$NI} arguments to that list as a separate element, with spaces between elements. If ${$I}listVar${$NI} does not exist, it is created as a list with elements given by the value arguments. If @@ -2008,9 +2543,11 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::lassign - @cmd -name "builtin: lassign" -help\ - "Assign list elements to variables. - This command treats the value ${$I}list${$NI} as a list and assigns + @cmd -name "builtin: lassign"\ + -summary\ + "Assign list elements to variables."\ + -help\ + "This command treats the value ${$I}list${$NI} as a list and assigns successive elements from that list to the variables given by the ${$I}varName${$NI} arguments in order. If there are more variable names than list elements, the remaining variables are set to the @@ -2026,9 +2563,38 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::ledit - @cmd -name "builtin: ledit" -help\ - "Replace elements of a list stored in variable. - " + @cmd -name "builtin: ledit"\ + -summary\ + "Replace elements of a list stored in variable."\ + -help\ + "The command fetches the list value in variable listVar and replaces the + elements in the range given by indices first to last (inclusive) with the + value arguments. The resulting list is then stored back in listVar and + returned as the result of the command. + Arguments first and last are index values specifying the first and last + elements of the range to replace. They are interpreted the same as index + values for the command ${$B}string index${$N}, supporting simple index arithmetic + and indices relative to the end of the list. The index ${$B}0${$N} refers to the + first element of the list, and end refers to the last element of the list. + (Unlike with ${$B}lpop${$N}, ${$B}lset${$N}, and ${$B}lindex${$N}, indices into sublists are not + supported.) + + If either first or last is less than zero, it is considered to refer to the + position before the first element of the list. This allows elements to be + prepended. + + If either first or last indicates a position greater than the index of the + last element of the list, it is treated as if it is an index one greater + than the last element. This allows elements to be appended. + + If last is less than first, then any specified elements will be inserted + into the list before the element specified by first with no elements being + deleted. + + The value arguments specify zero or more new elements to be added to the + list in place of those that were deleted. Each value argument will become a + separate element of the list. If no value arguments are specified, the + elements between first and last are simply deleted." @values -min 3 -max -1 listVar -type string -help\ "Existing list variable name" @@ -2041,13 +2607,10 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::lindex - @cmd -name "builtin: lindex" -help\ - "Retrieve an element from a list - " - @values -min 1 -max -1 - list -type list -help\ - "tcl list as a value" - index -type indexexpression -multiple 1 -optional 1 -help\ + @cmd -name "builtin: lindex"\ + -summary\ + "Retrieve an element from a list."\ + -help\ "When no index is supplied or a single index is supplied as an empty list, the value of the entire list is simply returned. @@ -2073,15 +2636,21 @@ tcl::namespace::eval punk::args::tclcore { If additional index arguments are supplied, then each argument is used in turn to select an element from the previous indexing operation, allowing the script to select elements from sublists." + @values -min 1 -max -1 + list -type list -help\ + "tcl list as a value" + index -type indexexpression -multiple 1 -optional 1 } "@doc -name Manpage: -url [manpage_tcl lindex]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::linsert - @cmd -name "builtin: linsert" -help\ - "Insert elements into a list. - This command produces a new list from ${$I}list${$NI} by insertaing all of the + @cmd -name "builtin: linsert"\ + -summary\ + "Insert elements into a list."\ + -help\ + "This command produces a new list from ${$I}list${$NI} by insertaing all of the ${$I}element${$NI} arguments just before the ${$I}index${$NI}'th element of list. Each ${$I}element${$NI} argument will become a separate element of the new list. If ${$I}index${$NI} is less than or equal to zero, then the new elements are @@ -2106,10 +2675,11 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::list - @cmd -name "builtin: list" -help\ - "Create a list - - This command returns a list comprised of all the args, or an empty string + @cmd -name "builtin: list"\ + -summary\ + "Create a list."\ + -help\ + "This command returns a list comprised of all the args, or an empty string if no args are specified. Braces and backslashes get added as necessary, so that the lindex command may be used on the result to re-extract the original arguments, and also so that eval may be used to execute the @@ -2124,9 +2694,11 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::llength - @cmd -name "builtin: llength" -help\ - "Count the number of elements in a list. - Treats ${$I}list${$NI} as a list and returns a decimal string giving the + @cmd -name "builtin: llength"\ + -summary\ + "Count the number of elements in a list."\ + -help\ + "Treats ${$I}list${$NI} as a list and returns a decimal string giving the number of elements in it." @values -min 1 -max 1 list -type list -help\ @@ -2136,7 +2708,10 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::lmap - @cmd -name "Builtin: lmap" -help\ + @cmd -name "Builtin: lmap"\ + -summary\ + "Iterate over all elements in one or more lists and collect results."\ + -help\ "The ${$B}lmap${$N} command implements a loop where the loop variable(s) take on values from one or more lists, and the loop returns a list of results collected from each iteration. @@ -2144,7 +2719,7 @@ tcl::namespace::eval punk::args::tclcore { that is a list of values to assign to ${$I}varName${$NI}. The ${$I}body${$NI} argument is a Tcl script. For each element of ${$I}list${$NI} (in order from first to last), ${$B}lmap${$N} assigns the contents of the element to ${$I}varName${$NI} - as if the ${$B}lindex${$NI} command had been used to extract the element, then + as if the ${$B}lindex${$N} command had been used to extract the element, then calls the Tcl interpreter to execute ${$I}body${$NI}. If execution of the body completes normally then the result of body is appended to an accumulator list. ${$B}lmap${$N} returns the accumulator list. @@ -2163,7 +2738,7 @@ tcl::namespace::eval punk::args::tclcore { In these cases the body does not complete normally and the result is not appended to the accumulator list." @values - "varlist list" -type {list list} -multiple 1 -optional 0 + "varlist list" -type {list list} -typesynopsis {varlist list} -multiple 1 -optional 0 body -type string -optional 0 -help\ "Tcl script" } "@doc -name Manpage: -url [manpage_tcl lmap]" ] @@ -2171,9 +2746,11 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::lpop - @cmd -name "builtin: lpop" -help\ - "Get and remove an element in a list. - The ${$B}lpop${$N} command acepts a parameter, ${$I}varName${$NI}, which + @cmd -name "builtin: lpop"\ + -summary\ + "Get and remove an element in a list."\ + -help\ + "The ${$B}lpop${$N} command acepts a parameter, ${$I}varName${$NI}, which it interprets as the name of a variable containing a Tcl list. It also accepts one or more ${$I}indices${$NI} into the list. If no indices are presented, it defaults to \"${$B}end${$N}\"." @@ -2196,9 +2773,11 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::lrange - @cmd -name "builtin: lrange" -help\ - "return one or more adjacent elements from a list. - The new list returned consists of elements first through last, inclusive. + @cmd -name "builtin: lrange"\ + -summary\ + "return one or more adjacent elements from a list."\ + -help\ + "The new list returned consists of elements first through last, inclusive. The index values first and last are interpreted the same as index values for the command 'string index', supporting simple index arithmetic and indices relative to the end of the list. @@ -2216,9 +2795,11 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::lrepeat - @cmd -name "builtin: lrepeat" -help\ - "Build a list by repeating elements - The ${$B}lrepeat${$N} command creates a list of size count * number of + @cmd -name "builtin: lrepeat"\ + -summary\ + "Build a list by repeating elements."\ + -help\ + "The ${$B}lrepeat${$N} command creates a list of size count * number of elements by repeating ${$I}count${$NI} times the sequence of elements ${$I}element${$NI} ... count must be a non-negative integer, ${$I}element${$NI} can be any Tcl value." @@ -2231,9 +2812,11 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::lreplace - @cmd -name "builtin: lreplace" -help\ - "Replace elements in a list with new elements. - ${$B}lreplace${$N} returns a new list formed by replacing zero or more + @cmd -name "builtin: lreplace"\ + -summary\ + "Replace elements in a list with new elements."\ + -help\ + "${$B}lreplace${$N} returns a new list formed by replacing zero or more elements of ${$I}list${$NI} with the ${$I}element${$NI} arguments. ${$I}first${$NI} and ${$I}last${$NI} are index values specifying the first and last elements of the range to replace. The index values ${$I}first${$NI} and @@ -2267,9 +2850,11 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::lremove - @cmd -name "builtin: lremove" -help\ - "Remove elements from a list by index - lremove returns a new list formed by simultaneously removing zero or + @cmd -name "builtin: lremove"\ + -summary\ + "Remove elements from a list by index."\ + -help\ + "lremove returns a new list formed by simultaneously removing zero or more elements of list at each of the indices given by an arbitrary number of index arguments. The indices may be in any order and may be repeated; the element at index will only be removed once. The index @@ -2288,9 +2873,11 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::lreverse - @cmd -name "builtin: lreverse" -help\ - "Reverse the order of a list. - The ${$B}lreverse${$N} command returns a list that has the same elements + @cmd -name "builtin: lreverse"\ + -summary\ + "Reverse the order of a list."\ + -help\ + "The ${$B}lreverse${$N} command returns a list that has the same elements as its input list, ${$I}list${$NI}, exept with the elements in reverse order." @values -min 1 -max 1 @@ -2302,9 +2889,11 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::lset - @cmd -name "builtin: lset" -help\ - "Change an element in a list. - The ${$B}lset${$N} command accepts a parameter, ${$I}varName${$NI}, which + @cmd -name "builtin: lset"\ + -summary\ + "Change an element in a list."\ + -help\ + "The ${$B}lset${$N} command accepts a parameter, ${$I}varName${$NI}, which it interprets as the name of a variable containint a Tcl list. It also accepts zero or more ${$I}indices${$NI} into the list. The indices may be presented either consecutively on the command line, or grouped in a @@ -2369,9 +2958,11 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::lseq - @cmd -name "builtin: lseq" -help\ - "Build a numeric sequence returned as a list. - The ${$B}lseq${$N} command creates a sequence of numeric values using the given + @cmd -name "builtin: lseq"\ + -summary\ + "Build a numeric sequence returned as a list."\ + -help\ + "The ${$B}lseq${$N} command creates a sequence of numeric values using the given parameters ${$I}start${$NI}, ${$I}end${$NI} and ${$I}step${$NI}. The ${$I}operation${$NI} argument \"..\" or \"${$B}to${$N}\" defines the range. The \"${$B}count${$N}\" option is used to defina a count of the number of elements in the list. A short form use of the @@ -2427,12 +3018,120 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl lreverse]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + punk::args::define { + @id -id ::lsearch + @cmd -name "builtin: lsearch"\ + -summary\ + "See if a list contains a particular element."\ + -help\ + "This command searches the elements of list to see if one of them matches pattern. If so, the command returns + the index of the first matching element (unless the options -all or -inline are specified.) If not, the command + returns -1 or (if options -all or -inline are specified) the empty string. The option arguments indicates how + the elements of the list are to be matched against pattern. + + (documentation incomplete - punk::args fixes required for grouped mutually exlusive options and prefix calculation) + " + @leaders -min 0 -max 0 + @opts -type none -parsekey "-MATCHSTYLE" -group "MATCHING STYLE OPTIONS" -grouphelp\ + "If all matching style options are omitted, the default matching style is -glob. + If more than one matching style is specified, the last matching style given + takes precedence." + + -exact -typedefaults "-exact" -help\ + "Pattern is a literal string that is compared for exact equality against each list element." + -glob -typedefaults "-glob" -default "-glob" -help\ + "Pattern is a glob-style pattern which is matched against each list element using the same + rules as the string match command." + -regexp -typedefaults "-regexp" -help\ + "Pattern is treated as a regular expression and matched against each list element using the + rules described in the re_syntax reference page." + -sorted -typedefaults "-sorted" -help\ + "The list elements are in sorted order. If this option is specified, lsearch will use a more + efficient searching algorithm to search list. If no other options are specified, list is + assumed to be sorted in increasing order, and to contain ASCII strings. This option is + mutually exclusive with -glob and -regexp, and is treated exactly like -exact when either + -all or -not are specified." + + + @opts -type string -parsekey "" -group "GENERAL MODIFIER OPTIONS" + -all -type none -help\ + "Changes the result to be the list of all matching indices (or all matching values if -inline is specified as well.) + If indices are returned, the indices will be in ascending numeric order. If values are returned, the order of the + values will be the order of those values within the input list." + -inline -type none -help\ + "The matching value is returned instead of its index (or an empty string if no value matches.) If -all is also + specified, then the result of the command is the list of all values that matched." + -not -type none + -start -type none + + @opts -type none -parsekey "-CONTENTOPTION" -group "CONTENTS DESCRIPTION OPTIONS" -grouphelp\ + "These options describe how to interpret the items in the list being searched. They are only meaningful when + used with the -exact and -sorted options. If more than one is specified, the last one takes precedence. + The default is -ascii." + -ascii -typedefaults "-ascii" -default "-ascii" -help\ + "The list elements are to be examined as Unicode strings (the name is for backward-compatibility reasons.)" + -dictionary -typedefaults "-dictionary" -help\ + "The list elements are to be compared using dictionary-style comparisons (see lsort for a fuller + description). Note that this only makes a meaningful difference from the -ascii option when the -sorted + option is given, because values are only dictionary-equal when exactly equal." + -integer -typedefaults "-integer" -help\ + "The list elements are to be compared as integers." + -nocase -typedefaults "-nocase" -help\ + "Causes comparisons to be handled in a case-insensitive manner. Has no effect if combined with the + -dictionary, -integer, or -real options." + -real -typedefaults "-real" -help\ + "The list elements are to be compared as floating-point values." + + + # -groupdefault "-increasing" ??? + @opts -type none -parsekey "-SORTOPTION" -group "SORTED LIST OPTIONS" -grouphelp\ + "These options (only meaningful with the -sorted option) specify how the list is sorted. If more than one is + given, the last one takes precedence. The default option is -increasing." + -decreasing -typedefaults "-decreasing" -help\ + " The list elements are sorted in decreasing order. This option is only meaningful when used with -sorted." + -increasing -typedefaults "-increasing" -default "-increasing" -help\ + " The list elements are sorted in increasing order. This option is only meaningful when used with -sorted." + -bisect -typedefaults "-bisect" -help\ + " Inexact search when the list elements are in sorted order. For an increasing list the last index where + the element is less than or equal to the pattern is returned. For a decreasing list the last index where + the element is greater than or equal to the pattern is returned. If the pattern is before the first + element or the list is empty, -1 is returned. This option implies -sorted and cannot be used with either + -all or -not." + + @opts -type string -parsekey "" -group "NESTED LIST OPTIONS" -grouphelp\ + "These options are used to search lists of lists. They may be used with any other options." + -stride -type integer -default 1 -typesynopsis strideLength -help\ + "If this option is specified, the list is treated as consisting of groups of strideLength elements and the + groups are searched by either their first element or, if the -index option is used, by the element within + each group given by the first index passed to -index (which is then ignored by -index). The resulting + index always points to the first element in a group. + The list length must be an integer multiple of strideLength, which in turn must be at least 1. A + strideLength of 1 is the default and indicates no grouping." + -index -type list -typesynopsis indexList -help\ + "This option is designed for use when searching within nested lists. The indexList argument gives a path of + indices (much as might be used with the lindex or lset commands) within each element to allow the location + of the term being matched against." + -subindices -type none -help\ + "If this option is given, the index result from this command (or every index result when -all is also + specified) will be a complete path (suitable for use with lindex or lset) within the overall list to the + term found. This option has no effect unless the -index is also specified, and is just a convenience + short-cut." + @opts -parsekey "" -group "" + @values -min 2 -max 2 + list -type list + pattern -type string + } "@doc -name Manpage: -url [manpage_tcl lsearch]" + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::lsort - @cmd -name "builtin: lsort" -help\ - "Sort the elements of a list - This command sorts the elements of ${$I}list${$NI}, returning a new list + @cmd -name "builtin: lsort"\ + -summary\ + "Sort the elements of a list."\ + -help\ + "This command sorts the elements of ${$I}list${$NI}, returning a new list in sorted order. The implementation of the ${$B}lsort${$N} command uses the merge-sort algorithem which is a stable sort that has O(n log n) performance characteristics. @@ -2548,9 +3247,11 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::proc - @cmd -name "builtin: proc" -help\ - "Create a Tcl procedure. - The ${$B}proc${$N} command creates a new Tcl procedure named name, replacing + @cmd -name "builtin: proc"\ + -summary\ + "Create a Tcl procedure."\ + -help\ + "The ${$B}proc${$N} command creates a new Tcl procedure named name, replacing any existing command or procedure there may have been by that name. Whenever the new command is invoked, the contents of ${$I}body${$NI} will be executed by the Tcl interpreter. Normally, ${$I}name${$NI} is unqualified (does not include @@ -2607,15 +3308,232 @@ tcl::namespace::eval punk::args::tclcore { args -type list body -type script } "@doc -name Manpage: -url [manpage_tcl proc]" + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::puts + @cmd -name "builtin: puts"\ + -summary\ + "Write to a channel."\ + -help\ + "The ${$B}puts${$N} command has been superceded by the ${$B}chan puts${$N} command which + supports the same syntax and options." + @opts -prefix 0 + -nonewline -type none + @values -min 1 -max 2 + channel -type string -optional 1 + string -type string + } "@doc -name Manpage: -url [manpage_tcl puts]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { - @id -id ::set - @cmd -name "builtin: set" -help\ - "Read and write variables. + @id -id ::rename + @cmd -name "builtin: rename"\ + -summary\ + "Rename or delete a command."\ + -help\ + "Rename the command that used to be called ${$I}oldName${$NI} so that it is now called ${$I}newName${$NI}. If + ${$I}newName${$NI} is an empty string then ${$I}oldName${$NI} is deleted. ${$I}oldName${$NI} and ${$I}newName${$NI} may include + namespace qualifiers (names of containing namespaces). If a command is renamed into a + different namespace, future invocations of it will execute in the new namespace. The + ${$B}rename${$N} command returns an empty string as result." + @values -min 2 -max 2 + oldName -type string + newName -type string + } "@doc -name Manpage: -url [manpage_tcl rename]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::return + @cmd -name "builtin: return"\ + -summary\ + "Return from a procedure, or set return code of script."\ + -help\ + "In its simplest usage, the return command is used without options in the body of a + procedure to immediately return control to the caller of the procedure. If a result + argument is provided, its value becomes the result of the procedure passed back to + the caller. If result is not specified then an empty string will be returned to the + caller as the result of the procedure. + The return command serves a similar function within script files that are evaluated + by the source command. When source evaluates the contents of a file as a script, an + invocation of the return command will cause script evaluation to immediately cease, + and the value result (or an empty string) will be returned as the result of the + source command. + + In addition to the result of a procedure, the return code of a procedure may also be + set by return through use of the -code option. In the usual case where the -code + option is not specified the procedure will return normally. However, the -code option + may be used to generate an exceptional return from the procedure. + + ${$B}RETURN OPTIONS${$N} + In addition to a result and a return code, evaluation of a command in Tcl also produces + a dictionary of return options. In general usage, all option value pairs given as + arguments to return become entries in the return options dictionary, and any values at + all are acceptable except as noted below. The catch command may be used to capture all + of this information — the return code, the result, and the return options dictionary — + that arise from evaluation of a script. + + As documented above, the -code entry in the return options dictionary receives special + treatment by Tcl. There are other return options also recognized and treated specially + by Tcl. They are: -errorcode, -errorinfo, -errorstack, -level, -options. + + ${$B}RETURN CODE HANDLINE MECHANISMS${$N} + Return codes are used in Tcl to control program flow. A Tcl script is a sequence of Tcl + commands. So long as each command evaluation returns a return code of TCL_OK, evaluation + will continue to the next command in the script. Any exceptional return code (non-TCL_OK) + returned by a command evaluation causes the flow on to the next command to be interrupted. + Script evaluation ceases, and the exceptional return code from the command becomes the + return code of the full script evaluation. This is the mechanism by which errors during + script evaluation cause an interruption and unwinding of the call stack. It is also the + mechanism by which commands like break, continue, and return cause script evaluation to + terminate without evaluating all commands in sequence. + Some of Tcl's built-in commands evaluate scripts as part of their functioning. These + commands can make use of exceptional return codes to enable special features. For example, + the built-in Tcl commands that provide loops — such as while, for, and foreach — evaluate + a script that is the body of the loop. If evaluation of the loop body returns the return + code of TCL_BREAK or TCL_CONTINUE, the loop command can react in such a way as to give the + break and continue commands their documented interpretation in loops. + + Procedure invocation also involves evaluation of a script, the body of the procedure. + Procedure invocation provides special treatment when evaluation of the procedure body + returns the return code TCL_RETURN. In that circumstance, the -level entry in the return + options dictionary is decremented. If after decrementing, the value of the -level entry is + 0, then the value of the -code entry becomes the return code of the procedure. If after + decrementing, the value of the -level entry is greater than zero, then the return code of + the procedure is TCL_RETURN. If the procedure invocation occurred during the evaluation of + the body of another procedure, the process will repeat itself up the call stack, + decrementing the value of the -level entry at each level, so that the code will be the + return code of the current command level levels up the call stack. The source command + performs the same handling of the TCL_RETURN return code, which explains the similarity of + return invocation during a source to return invocation within a procedure. + + The return code of the return command itself triggers this special handling by procedure + invocation. If return is provided the option -level 0, then the return code of the return + command itself will be the value code of the -code option (or TCL_OK by default). Any + other value for the -level option (including the default value of 1) will cause the return + code of the return command itself to be TCL_RETURN, triggering a return from the enclosing + procedure." + + @form -form basic + @form -form code + @form -form options + + @leaders -form {basic code options} -min 0 -max 0 + + @opts -form {code options} + -code -form {code options} -default 0\ + -type int\ + -typesynopsis {${$I}choice${$NI}|<${$I}int${$NI}>}\ + -help\ + "When a value is given outside of the listed choices, it's value must be an + integer; it will be returned as the return code for the current procedure. + Applications and packages should use values in the range 5 to 1073741823 + (0x3fffffff) for their own purposes. Values outside this range are reserved + for use by Tcl. + + When a procedure wants to signal that it has received invalid arguments from + its caller, it may use return -code error with result set to a suitable error + message. Otherwise usage of the return -code option is mostly limited to + procedures that implement a new control structure. + + The return -code command acts similarly within script files that are evaluated + by the source command. During the evaluation of the contents of a file as a + script by source, an invocation of the return -code code command will cause the + return code of source to be code."\ + -choicecolumns 2\ + -choiceprefix 0\ + -choicerestricted 0\ + -choices {ok 0 error 1 return 2 break 3 continue 4}\ + -choicelabels { + ok\ + " Normal return: same as if the option is omitted. + The return code of the procedure is 0 (TCL_OK)." + error\ + " Error return: the return code of the procedure is + 1 (TCL_ERROR). The procedure command behaves in + its calling context as if it were the command + error result. See below for additional options." + return\ + " The return code of the procedure is 2 + (TCL_RETURN). The procedure command behaves in its + calling context as if it were the command return + (with no arguments)." + break\ + " The return code of the procedure is 3 (TCL_BREAK). + The procedure command behaves in its calling + context as if it were the command break." + continue\ + "The return code of the procedure is 4 + (TCL_CONTINUE). The procedure command behaves in + its calling context as if it were the command + continue." + } - Returns the value of variable ${$I}varName${$NI}. If ${$I}value${$NI} is specified, + -errorcode -form options -type list -help\ + "The -errorcode option receives special treatment only when the value of the + -code option is TCL_ERROR. Then the list value is meant to be additional + information about the error, presented as a Tcl list for further processing + by programs. If no -errorcode option is provided to return when the -code + error option is provided, Tcl will set the value of the -errorcode entry in + the return options dictionary to the default value of NONE. The -errorcode + return option will also be stored in the global variable errorCode." + -errorinfo -form options -type list -typesynopsis ${$I}info${$NI} -help\ + "The -errorinfo option receives special treatment only when the value of the + -code option is TCL_ERROR. Then info is the initial stack trace, meant to + provide to a human reader additional information about the context in which + the error occurred. The stack trace will also be stored in the global + variable errorInfo. If no -errorinfo option is provided to return when the + -code error option is provided, Tcl will provide its own initial stack trace + value in the entry for -errorinfo. Tcl's initial stack trace will include + only the call to the procedure, and stack unwinding will append information + about higher stack levels, but there will be no information about the + context of the error within the procedure. Typically the info value is + supplied from the value of -errorinfo in a return options dictionary + captured by the catch command (or from the copy of that information stored in + the global variable errorInfo)." + -errorstack -form options -type list -help\ + "The -errorstack option receives special treatment only when the value of the + -code option is TCL_ERROR. Then list is the initial error stack, recording + actual argument values passed to each proc level. The error stack will also + be reachable through info errorstack. If no -errorstack option is provided to + return when the -code error option is provided, Tcl will provide its own + initial error stack in the entry for -errorstack. Tcl's initial error stack + will include only the call to the procedure, and stack unwinding will append + information about higher stack levels, but there will be no information about + the context of the error within the procedure. Typically the list value is + supplied from the value of -errorstack in a return options dictionary + captured by the catch command (or from the copy of that information from info + errorstack)." + -level -form options -type integer -range {0 ""} -typesynopsis ${$I}level${$NI} -help\ + "The -level and -code options work together to set the return code to be + returned by one of the commands currently being evaluated. The level value must + be a non-negative integer representing a number of levels on the call stack. It + defines the number of levels up the stack at which the return code of a command + currently being evaluated should be code. If no -level option is provided, the + default value of level is 1, so that return sets the return code that the + current procedure returns to its caller, 1 level up the call stack. The + mechanism by which these options work is described in more detail below." + -options -form options -type dict -help\ + "The value options must be a valid dictionary. The entries of that dictionary + are treated as additional option value pairs for the return command." + + + @values -form * -min 0 -max 1 + result -form * -type string -optional 1 + + + } "@doc -name Manpage: -url [manpage_tcl return]" + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::set + @cmd -name "builtin: set"\ + -summary\ + "Read and write variables."\ + -help\ + "Returns the value of variable ${$I}varName${$NI}. If ${$I}value${$NI} is specified, then set the value of ${$I}varName${$NI} to ${$I}value${$NI}, creating a new variable if one does not already exist, and return its value. If ${$I}varName${$NI} contains an open parenthesis and ends with a close parenthesis, @@ -2655,9 +3573,11 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::split - @cmd -name "builtin: split" -help\ - "Split a string into a proper Tcl list. - Returns a list created by splitting string at each character that is in + @cmd -name "builtin: split"\ + -summary\ + "Split a string into a proper Tcl list."\ + -help\ + "Returns a list created by splitting string at each character that is in the ${$I}splitChars${$NI} argument. Each element of the result list will consist of the characters from ${$I}string${$NI} that lie between instances of the characters in ${$I}splitChars${$NI}. Empty list elements will be @@ -2678,15 +3598,17 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id ::tcl::string::cat - @cmd -name "builtin: tcl::string::cat" -help\ - "Concatenate the given strings just like placing them directly next to each other and + @cmd -name "builtin: tcl::string::cat"\ + -summary\ + "Concatenate strings."\ + -help\ + "Concatenate the given strings just like placing them directly next to each other and return the resulting compound string. If no strings are present, the result is an empty string. This primitive is occasionally handier than juxtaposition of strings when mixed quoting is wanted, or when the aim is to return the result of a concatentation without resorting to return -level 0, and is more efficient than building a list of arguments and using join with an empty join string." - @form -synopsis "string cat ?string...?" @values -min 0 -max -1 string -type string -optional 1 -multiple 1 } "@doc -name Manpage: -url [manpage_tcl string]" @@ -2714,7 +3636,10 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id ::tcl::string::equal - @cmd -name "builtin: tcl::string::equal" -help\ + @cmd -name "builtin: tcl::string::equal"\ + -summary\ + "Compare strings."\ + -help\ "Perform a character-by-character comparison of strings string1 and string2. Returns 1 if string1 and string2 are identical, or 0 when not." @@ -2891,7 +3816,10 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id ::tcl::string::repeat - @cmd -name "builtin: tcl::string::repeat" -help\ + @cmd -name "builtin: tcl::string::repeat"\ + -summary\ + "Build a string by repeating elements."\ + -help\ "Returns a string consisting of string concatenated with itself count times." @values -min 2 -max 2 string -type string @@ -3210,9 +4138,11 @@ tcl::namespace::eval punk::args::tclcore { namespace eval argdoc { punk::args::define { @id -id ::subst - @cmd -name "builtin: subst" -help\ - "Perform backslash, command, and variable substitutions. - This command performs variable substitutions, command substitutions, + @cmd -name "builtin: subst"\ + -summary\ + "Perform backslash, command, and variable substitutions."\ + -help\ + "This command performs variable substitutions, command substitutions, and backslash substitutions on its ${$I}string${$NI} argument and returns the fully-substituted result. The substitutions are performed in exactly the same way as for Tcl commands. As a result, the ${$I}string${$NI} argument is @@ -3255,13 +4185,105 @@ tcl::namespace::eval punk::args::tclcore { } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- namespace eval argdoc { + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::switch + @cmd -name "builtin: switch"\ + -summary\ + "Evaluate one of several scripts, depending on a given value."\ + -help\ + "The ${$B}switch${$N} command matches its ${$I}string${$NI} argument against each of the ${$I}pattern${$NI} arguments + in order. As soon as it finds a ${$I}pattern${$NI} that matches ${$I}string${$NI} it evaluates the following + ${$I}body${$NI} argument by passing it recursively to the Tcl interpreter and returns the result + of that evaluation. If the last ${$I}pattern${$NI} argument is ${$B}default${$N} then it matches anything. + If no ${$I}pattern${$NI} argument matches ${$I}string${$NI} and no default is given, then the ${$B}switch${$N} command + returns an empty string. + If the initial arguments to ${$B}switch${$N} start with - then they are treated as options unless + there are exactly two arguments to ${$B}switch${$N} (in which case the first must the ${$I}string${$NI} and + the second must be the ${$I}pattern/body${$NI} list). + + Two syntaxes are provided for the ${$I}pattern${$NI} and ${$I}body${$NI} arguments. The first uses a separate + argument for each of the patterns and commands; this form is convenient if substitutions + are desired on some of the patterns or commands. The second form places all of the + patterns and commands together into a single argument; the argument must have proper + list structure, with the elements of the list being the patterns and commands. The + second form makes it easy to construct multi-line switch commands, since the braces + around the whole list make it unnecessary to include a backslash at the end of each + line. Since the ${$I}pattern${$NI} arguments are in braces in the second form, no command or + variable substitutions are performed on them; this makes the behavior of the second form + different than the first form in some cases. + + If a ${$I}body${$NI} is specified as “-” it means that the ${$I}body${$NI} for the next pattern should also be + used as the body for this pattern (if the next pattern also has a body of “-” then the + body after that is used, and so on). This feature makes it possible to share a single + ${$I}body${$NI} among several patterns. + + Beware of how you place comments in ${$B}switch${$N} commands. Comments should only be placed + ${$B}inside${$N} the execution body of one of the patterns, and not intermingled with the + patterns." + + @form -form separate + @form -form block + @leaders -form {separate block} -min 0 -max 0 + + @form -form {separate block} + @opts + -exact -type none -help\ + "Use exact matching when comparing ${$I}string${$NI} to a pattern. This is the default." + -glob -type none -help\ + "When matching ${$I}string${$NI} to the patterns, use glob-style matching (i.e. the same as + implemented by the ${$B}string match${$N} command)." + -regexp -type none -help\ + "When matching ${$I}string${$NI} to the patterns, use regular expression matching (as described + in the ${$B}re_syntax${$N} reference page)." + -nocase -type none -help\ + "Causes comparisons to be handled in a case-insensitive manner." + #matchvar/indexvar only legel when -regexp specified !todo + -matchvar -type string -typesynopsis ${$I}varName${$NI} -help\ + "This option (only legal when ${$B}-regexp${$N} is also specified) specifies the name of a variable into + which the list of matches found by the regular expression engine will be written. The first + element of the list written will be the overall substring of the input string (i.e. the + string argument to ${$B}switch${$N}) matched, the second element of the list will be the substring + matched by the first capturing parenthesis in the regular expression that matched, and so on. + When a ${$B}default${$N} branch is taken, the variable will have the empty list written to it. This + option may be specified at the same time as the ${$B}-indexvar${$N} option." + -indexvar -type string -typesynopsis ${$I}varName${$NI} -help\ + "This option (only legal when ${$B}-regexp${$N} is also specified) specifies the name of a variable into which the + list of indices referring to matching substrings found by the regular expression engine will be written. + The first element of the list written will be a two-element list specifying the index of the start and + index of the first character after the end of the overall substring of the input string (i.e. the string + argument to switch) matched, in a similar way to the ${$B}-indices${$N} option to ${$B}regexp${$N} can obtain. Similarly, + the second element of the list refers to the first capturing parenthesis in the regular expression that + matched, and so on. When a ${$B}default${$N} branch is taken, the variable will have the empty list written to it. + This option may be specified at the same time as the ${$B}-matchvar${$N} option." + -- -type none -help\ + "Marks the end of options. The argument following this one will be treated as string even if it starts with a -. + This is not required when the matching patterns and bodies are grouped together in a single argument." + + @values -form separate -min 3 -max -1 + @values -form block -min 2 -max 2 + + string -form * -type string -help\ + "string to match for." + + "pattern body" -form separate -type {string script} -typesynopsis {${$I}pattern${$NI} ${$I}body${$NI}} -optional 0 -multiple 1 + + "{pattern body ?pattern body?...}" -form block -type dict + + } "@doc -name Manpage: -url [manpage_tcl switch]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + punk::args::define { @id -id ::tailcall - @cmd -name "builtin: tailcall" -help\ - "Replace the current procedure with another command. - The ${$B}tailcall${$N} command replaces the currently executing procedure, + @cmd -name "builtin: tailcall"\ + -summary\ + "Replace the current procedure with another command."\ + -help\ + "The ${$B}tailcall${$N} command replaces the currently executing procedure, lambda aplication, or method with another command. The ${$I}command${$NI}, which will have ${$I}arg${$NI} ... passed as arguments if they are supplied, will be looked up in the current namespace context, not in the caller's. @@ -3280,9 +4302,13 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::trace - @cmd -name "builtin: trace" -help\ - "Monitor variable accesses, command usages and command executions - " + @cmd -name "builtin: 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 { @@ -3482,9 +4508,11 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::variable - @cmd -name "builtin: variable" -help\ - "Create and initialise a namespace variable. - This command is normally used within a namespace eval command to create one + @cmd -name "builtin: variable"\ + -summary\ + "Create and initialise a namespace variable."\ + -help\ + "This command is normally used within a namespace eval command to create one or more variables within a namespace. Each variable name is initialized with value. The value for the last variable is optional. If a variable name does not exist, it is created. In this case, if value is @@ -3540,12 +4568,161 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- namespace eval argdoc { + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::unset + @cmd -name "Builtin: unset"\ + -summary\ + {Delete variables.}\ + -help\ + "This command removes one or more variables. Each name is a variable name, + specified in any of the ways acceptable to the ${$B}set${$N} command. If a ${$I}name${$NI} refers + to an element of an array then that element is removed without affecting the + rest of the array. If a name consists of an array name with no parenthesized + index, then the entire array is deleted. The ${$B}unset${$N} command returns an empty + string as result. If ${$B}-nocomplain${$N} is specified as the first argument, any + possible errors are suppressed. The option may not be abbreviated, in order + to disambiguate it from possible variable names. The option -- indicates the + end of the options, and should be used if you wish to remove a variable with + the same name as any of the options. If an error occurs during variable + deletion, any variables after the named one causing the error are not deleted. + An error can occur when the named variable does not exist, or the name refers + to an array element but the variable is a scalar, or the name refers to a + variable in a non-existent namespace." + @leaders -min 0 -max 0 + @opts + -nocomplain -type none + -- -type none + @values -min 0 -max -1 + name -type string -multiple 1 -optional 1 + } "@doc -name Manpage: -url [manpage_tcl upvar]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::uplevel + @cmd -name "Builtin: uplevel"\ + -summary\ + "Execute a script in a different stack frame."\ + -help\ + {All of the ${$I}arg${$NI} arguments are concatenated as if they had been passed to + ${$B}concat${$N}; the result is then evaluated in the variable context indicated by + ${$I}level${$NI}. ${$B}Uplevel${$N} returns the result of that evaluation. + If ${$I}level${$NI} is an integer then it gives a distance (up the procedure calling + stack) to move before executing the command. If ${$I}level${$NI} consists of ${$B}#${$N} + followed by an integer then the level gives an absolute level. If ${$I}level${$NI} is + omitted then it defaults to ${$B}1${$N}. ${$I}Level${$NI} cannot be defaulted if the first + command argument is an integer or starts with ${$B}#${$N}. + + For example, suppose that procedure a was invoked from top-level, and that + it called b, and that b called c. Suppose that c invokes the uplevel + command. If level is 1 or #2 or omitted, then the command will be executed + in the variable context of b. If level is 2 or #1 then the command will be + executed in the variable context of a. If level is 3 or #0 then the command + will be executed at top-level (only global variables will be visible). + + The uplevel command causes the invoking procedure to disappear from the + procedure calling stack while the command is being executed. In the above + example, suppose c invokes the command: + ${[punk::args::tclcore::argdoc::example { + uplevel 1 {set x 43; d}}]} + where d is another Tcl procedure. The set command will modify the variable + x in b's context, and d will execute at level 3, as if called from b. If it + in turn executes the command: + ${[punk::args::tclcore::argdoc::example { + uplevel 1 {set x 42}}]} + then the set command will modify the same variable x in b's context: the + procedure c does not appear to be on the call stack when d is executing. + The info level command may be used to obtain the level of the current + procedure. + + ${$B}Uplevel${$N} makes it possible to implement new control constructs as Tcl + procedures (for example, uplevel could be used to implement the while + construct as a Tcl procedure). + + The ${$B}namespace eval${$N} and ${$B}apply${$N} commands offer other ways (besides procedure + calls) that the Tcl naming context can change. They add a call frame to the + stack to represent the namespace context. This means each ${$B}namespace eval${$N} + command counts as another call level for ${$B}uplevel${$N} and ${$B}upvar${$N} commands. For + example, ${$B}info level 1${$N} will return a list describing a command that is either + the outermost procedure call or the outermost ${$B}namespace eval${$N} command. Also, + ${$B}uplevel #0${$N} evaluates a script at top-level in the outermost namespace (the + global namespace).} + @leaders -min 0 -max 1 + level -type int|stringprefix(#) -optional 1 -default 1 + @values -min 1 -max -1 + arg -type string -optional 0 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl uplevel]" ] + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::upvar + @cmd -name "Builtin: upvar"\ + -summary\ + {Create link to variable in a different stack frame.}\ + -help\ + {This command arranges for one or more local variables in the current procedure + to refer to variables in an enclosing procedure call or to global variables. + Level may have any of the forms permitted for the ${$B}uplevel${$N} command, and may be + omitted (it defaults to 1). For each otherVar argument, upvar makes the + variable by that name in the procedure frame given by level (or at global level, + if level is #0) accessible in the current procedure by the name given in the + corresponding myVar argument. The variable named by otherVar need not exist at + the time of the call; it will be created the first time myVar is referenced, + just like an ordinary variable. There must not exist a variable by the name + myVar at the time upvar is invoked. MyVar is always treated as the name of a + variable, not an array element. An error is returned if the name looks like an + array element, such as ${$B}a(b)${$N}. OtherVar may refer to a scalar variable, an array, + or an array element. Upvar returns an empty string. + The upvar command simplifies the implementation of call-by-name procedure + calling and also makes it easier to build new control constructs as Tcl + procedures. + For example, consider the following procedure: + ${[punk::args::tclcore::argdoc::example { + proc add2 name { + upvar $name x + set x [expr {$x + 2}] + }}]} + If add2 is invoked with an argument giving the name of a variable, it adds + two to the value of that variable. Although add2 could have been implemented + using ${$B}uplevel${$N} instead of ${$B}upvar${$N}, ${$B}upvar${$N} makes it simpler for add2 to access the + variable in the caller's procedure frame. + + ${$B}namespace eval${$N} is another way (besides procedure calls) that the Tcl naming + context can change. It adds a call frame to the stack to represent the namespace + context. This means each ${$B}namespace eval${$N} command counts as another call level for + ${$B}uplevel${$N} and ${$B}upvar${$N} commands. For example, ${$B}info level 1${$N} will return a list + describing a command that is either the outermost procedure call or the outermost + ${$B}namespace eval${$N} command. Also, ${$B}uplevel #0${$N} evaluates a script at top-level in the + outermost namespace (the global namespace). + + If an upvar variable is unset (e.g. ${$B}x${$N} in ${$B}add2${$N} above), the ${$B}unset${$N} operation affects + the variable it is linked to, not the upvar variable. There is no way to unset an + upvar variable except by exiting the procedure in which it is defined. However, it + is possible to retarget an upvar variable by executing another ${$B}upvar${$N} command.} + @leaders -min 0 -max 1 -takewhenargsmodulo 2 + #consider -takewhenargsmodulo 2 ?? incompatible with various mixed @opts/@values configurations + #level -type int|stringprefix(#) -optional 1 -default 1 + # stringregexp(^#[0-9]$) + # stringsuffix(xxx) + + #todo - review + #this leader is greedy - i.e if the type matches it will take it. + #this is at odds with the way Tcl parses upvar args - it seems to look at the number of total args + #and will not assign a first value that passes int|stringprefix(#) to 'level' if there is an even number of args in total + #e.g tcl will accept: upvar #1 blah #2 etc + level -type int|stringprefix(#) -optional 1 -default 1 + @values -min 2 -max -1 + varmapping -type {string string} -typesynopsis {${$I}otherVar${$NI} ${$I}myVar${$NI}} -optional 0 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl upvar]" ] + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::while - @cmd -name "Builtin: while" -help\ - {Execute script repeatedly as long as a condition is met. - The ${$B}while${$N} command evaluates test as an expression (in the same way + @cmd -name "Builtin: while"\ + -summary\ + {Execute script repeatedly as long as a condition is met.}\ + -help\ + {The ${$B}while${$N} command evaluates test as an expression (in the same way that ${$B}expr${$N} evaluates its argument). The value of the expression must a proper boolean value; if it is a true value then body is executed by passing it to the Tcl interpreter. Once body has been executed then test is evaluated again, @@ -3592,7 +4769,10 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @dynamic @id -id "::zlib adler32" - @cmd -name "builtin: ::zlib adler32" -help\ + @cmd -name "builtin: ::zlib adler32"\ + -summary\ + "Compute Adler-32 checksum."\ + -help\ "Compute a checksum of binary string ${$I}string${$NI} using the Adler32 algorithm. If given, ${$I}initValue${$NI} is used to initialize the checksum engine. " @@ -3605,7 +4785,10 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @dynamic @id -id "::zlib crc32" - @cmd -name "builtin: ::zlib crc32" -help\ + @cmd -name "builtin: ::zlib crc32"\ + -summary\ + "Compute CRC-32 checksum."\ + -help\ "Compute a checksum of binary string ${$I}string${$NI} using the CRC-32 algorithm. If given, ${$I}initValue${$NI} is used to initialize the checksum engine. " @@ -3618,7 +4801,10 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @dynamic @id -id "::zlib compress" - @cmd -name "builtin: ::zlib compress" -help\ + @cmd -name "builtin: ::zlib compress"\ + -summary\ + "Compress with zlib-format."\ + -help\ "Returns the zlib-format compressed binary data of the binary string in ${$I}string${$NI}. If present, ${$I}level${$NI} gives the compression level to use (from 0, which is uncompressed, to 9, maximally compressed)." @@ -3630,7 +4816,10 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @dynamic @id -id "::zlib decompress" - @cmd -name "builtin: ::zlib compress" -help\ + @cmd -name "builtin: ::zlib decompress"\ + -summary\ + "Decompress zlib-format."\ + -help\ "Returns the uncompressed version of the raw compressed binary data in ${$I}string${$NI}. If present, ${$I}bufferSize${$NI} is a hint as to what size of buffer is to be used to receive the data." @@ -3652,7 +4841,10 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id "::zlib push" - @cmd -name "builtin: ::zlib push" -help\ + @cmd -name "builtin: ::zlib push"\ + -summary\ + "Push a compressing/decompressing transform onto a channel."\ + -help\ "Pushes a compressing or decompressing transformation onto the channel channel. The transformation can be removed again with chan pop. The mode argument determines what type of transformation is pushed. @@ -3749,7 +4941,10 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id "::zlib gunzip" - @cmd -name "builtin: ::zlib gunzip" -help\ + @cmd -name "builtin: ::zlib gunzip"\ + -summary\ + "Decompress gzip format."\ + -help\ "Return the uncompressed contents of binary string ${$I}string${$NI}, which must have been in gzip format. If ${$B}-headerVar${$N} is given, store a dictionary describing the contents of the gzip header in the variable called varName. The keys of the @@ -3780,7 +4975,10 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id "::zlib gzip" - @cmd -name "builtin: ::zlib gzip" -help\ + @cmd -name "builtin: ::zlib gzip"\ + -summary\ + "Compress with gzip format."\ + -help\ "Return the compressed contents of binary string string in gzip format. If -level is given, level gives the compression level to use (from 0, which is uncompressed, to 9, maximally compressed). If -header is given, @@ -3845,9 +5043,13 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id ::zlib - @cmd -name "builtin: ::zlib" -help\ - "zlib - compression and decompression operations - zlib version: ${$ZLIBVERSION}" + @cmd -name "builtin: ::zlib"\ + -summary\ + "Zlib library compression and decompression operations."\ + -help\ + "zlib version: ${$ZLIBVERSION} + The zlib command provides access to the compression and check-summing facilities of the Zlib library + by Jean-loup Gailly and Mark Adler." @leaders -min 1 -max 1 subcommand -type string\ -choicecolumns 2\ @@ -3873,10 +5075,11 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @dynamic @id -id ::zipfs - @cmd -name "builtin: ::zipfs" -help\ - "Mount and work with ZIP files within Tcl - - The ${$B}zipfs${$N} command provides Tcl with the ability to mount the contents of a + @cmd -name "builtin: ::zipfs"\ + -summary\ + "Mount and work with ZIP files within Tcl."\ + -help\ + "The ${$B}zipfs${$N} command provides Tcl with the ability to mount the contents of a ZIP archive file as a virtual file system. Tcl's ZIP archive support is limited to basic features and options. Supported storage methods include only STORE and DEFLATE with optional simple encryption, sufficient to @@ -4055,7 +5258,10 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::mkzip - @cmd -name "builtin: ::zipfs::mkzip" -help\ + @cmd -name "builtin: ::zipfs::mkzip"\ + -summary\ + "Create a 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 password. While processing the files below indir the optional file name @@ -4075,7 +5281,7 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @id -id ::tcl::zipfs::mkimg - @cmd -name "builtin: ::zipfs::mkzip" -help\ + @cmd -name "builtin: ::zipfs::mkimg" -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 diff --git a/src/modules/punk/console-999999.0a1.0.tm b/src/modules/punk/console-999999.0a1.0.tm index 8c85abaf..646a553c 100644 --- a/src/modules/punk/console-999999.0a1.0.tm +++ b/src/modules/punk/console-999999.0a1.0.tm @@ -1239,7 +1239,7 @@ namespace eval punk::console { lappend PUNKARGS [list { @id -id ::punk::console::show_input_response @cmd -name punk::console::show_input_response -help\ - "" + "Debug command for console queries using ANSI" @opts -terminal -default {stdin stdout} -type list -help\ "terminal (currently list of in/out channels) (todo - object?)" @@ -1247,9 +1247,9 @@ namespace eval punk::console { "Number of ms to wait for response" @values -min 1 -max 1 request -type string -help\ - "ANSI sequence such as \x1b\[?6n which + {ANSI sequence such as \x1b\[?6n which should elicit a response by the terminal - on stdin" + on stdin} }] proc show_input_response {args} { set argd [punk::args::parse $args withid ::punk::console::show_input_response] diff --git a/src/modules/punk/lib-999999.0a1.0.tm b/src/modules/punk/lib-999999.0a1.0.tm index 601aea37..dd9bba14 100644 --- a/src/modules/punk/lib-999999.0a1.0.tm +++ b/src/modules/punk/lib-999999.0a1.0.tm @@ -1173,6 +1173,7 @@ namespace eval punk::lib { -keysortdirection -default increasing -choices {increasing decreasing} -debug -default 0 -type boolean -help\ "When enabled, produces some rudimentary debug output on stderr" + -- -type none -optional 1 @values -min 1 -max -1 dictvalue -type list -help\ "dict or list value" diff --git a/src/modules/punk/ns-999999.0a1.0.tm b/src/modules/punk/ns-999999.0a1.0.tm index 4f3ca281..c1ad1131 100644 --- a/src/modules/punk/ns-999999.0a1.0.tm +++ b/src/modules/punk/ns-999999.0a1.0.tm @@ -2510,8 +2510,12 @@ tcl::namespace::eval punk::ns { punk::args::define { @id -id ::punk::ns::forms - @cmd -name punk::ns::forms -help\ - "Return names for each form of a command" + @cmd -name punk::ns::forms\ + -summary\ + "List command forms."\ + -help\ + "Return names for each form of a command. + Most commands are single-form and will only return the name '_default'." @opts @values -min 1 -max -1 cmditem -multiple 1 -optional 0 @@ -2525,10 +2529,13 @@ tcl::namespace::eval punk::ns { } punk::args::define { @id -id ::punk::ns::synopsis - @cmd -name punk::ns::synopsis -help\ + @cmd -name punk::ns::synopsis\ + -summary\ + "Return command synopsis."\ + -help\ "Return synopsis for each form of a command on separate lines. - If -form is given, supply only + If -form formname| is given, supply only the synopsis for that form. " @opts @@ -2564,8 +2571,12 @@ tcl::namespace::eval punk::ns { full - summary { set resultstr "" foreach synline [split $syn \n] { - #append resultstr [join [lreplace $synline 0 0 {*}$idparts] " "] \n - append resultstr [join [lreplace $synline 0 [llength $resolved_id]-1 {*}$idparts] " "] \n + if {[string range $synline 0 1] eq "# "} { + append resultstr $synline \n + } else { + #append resultstr [join [lreplace $synline 0 0 {*}$idparts] " "] \n + append resultstr [join [lreplace $synline 0 [llength $resolved_id]-1 {*}$idparts] " "] \n + } } set resultstr [string trimright $resultstr \n] #set resultstr [join [lreplace $syn 0 0 {*}$idparts] " "] @@ -2591,7 +2602,10 @@ tcl::namespace::eval punk::ns { punk::args::define { @dynamic @id -id ::punk::ns::arginfo - @cmd -name punk::ns::arginfo -help\ + @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 @@ -3020,8 +3034,11 @@ tcl::namespace::eval punk::ns { set arglist [lindex $constructorinfo 0] set argdef [punk::lib::tstr -return string { @id -id "(autodef)${$origin} new" - @cmd -name "${$origin} new" -help\ - "create object with specified command name. + @cmd -name "${$origin} new"\ + -summary\ + "Create new object instance."\ + -help\ + "create object with autogenerated command name. Arguments are passed to the constructor." @values }] @@ -3071,7 +3088,10 @@ tcl::namespace::eval punk::ns { set arglist [lindex $constructorinfo 0] set argdef [punk::lib::tstr -return string { @id -id "(autodef)${$origin} create" - @cmd -name "${$origin} create" -help\ + @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 @@ -3124,7 +3144,10 @@ tcl::namespace::eval punk::ns { # but we may want notes about a specific destructor set argdef [punk::lib::tstr -return string { @id -id "(autodef)${$origin} destroy" - @cmd -name "destroy" -help\ + @cmd -name "destroy"\ + -summary\ + "delete object instance."\ + -help\ "delete object, calling destructor if any. destroy accepts no arguments." @values -min 0 -max 0 @@ -3799,13 +3822,53 @@ tcl::namespace::eval punk::ns { } + punk::args::define { + @id -id ::punk::ns::pkguse + @cmd -name punk::ns::pkguse -help\ + "Load package and move to namespace of the same name if run + interactively with only pkg/namespace argument. + if script and args are supplied, the + script runs in the namespace with the args passed to the script. + + todo - further documentation" + @leaders -min 1 -max 1 + pkg_or_existing_ns -type string + @opts + -vars -type none -help\ + "whether to capture namespace vars for use in the supplied script" + -nowarnings -type none + @values -min 0 -max -1 + script -type string -optional 1 + arg -type any -optional 1 -multiple 1 + } #load package and move to namespace of same name if run interactively with only pkg/namespace argument. #if args is supplied - first word is script to run in the namespace remaining args are args passed to scriptblock #if no newline or $args in the script - treat as one-liner and supply {*}$args automatically - proc pkguse {pkg_or_existing_ns args} { - lassign [internal::get_run_opts {-vars -nowarnings} {} $args] _r runopts _c cmdargs - set use_vars [expr {"-vars" in $runopts}] - set no_warnings [expr {"-nowarnings" in $runopts}] + proc pkguse {args} { + set argd [punk::args::parse $args withid ::punk::ns::pkguse] + lassign [dict values $argd] leaders opts values received + puts stderr "leaders:$leaders opts:$opts values:$values received:$received" + + set pkg_or_existing_ns [dict get $leaders pkg_or_existing_ns] + if {[dict exists $received script]} { + set scriptblock [dict get $values script] + } else { + set scriptblock "" + } + if {[dict exists $received arg]} { + set arglist [dict get $values arg] + } else { + set arglist [list] + } + + set use_vars [dict exists $received "-vars"] + set no_warnings [dict exists $received "-nowarnings"] + + #lassign [internal::get_run_opts {-vars -nowarnings} {} $args] _r runopts _c cmdargs + #set use_vars [expr {"-vars" in $runopts}] + #set no_warnings [expr {"-nowarnings" in $runopts}] + + set ver "" @@ -3883,7 +3946,7 @@ tcl::namespace::eval punk::ns { } } if {[tcl::namespace::exists $ns]} { - if {[llength $cmdargs]} { + if {[dict exists $received script]} { set binding {} #if {[info level] == 1} { # #up 1 is global @@ -3923,7 +3986,7 @@ tcl::namespace::eval punk::ns { } ] - set arglist [lassign $cmdargs scriptblock] + #set arglist [lassign $cmdargs scriptblock] if {[string first "\n" $scriptblock] <0 && [string first {$args} $scriptblock] <0} { #one liner without use of $args append scriptblock { {*}$args} diff --git a/src/modules/punk/zip-999999.0a1.0.tm b/src/modules/punk/zip-999999.0a1.0.tm index 61191b1d..2ffa4454 100644 --- a/src/modules/punk/zip-999999.0a1.0.tm +++ b/src/modules/punk/zip-999999.0a1.0.tm @@ -420,7 +420,11 @@ tcl::namespace::eval punk::zip { punk::args::define { @id -id ::punk::zip::Addentry - @cmd -name punk::zip::Addentry -help "Add a single file at 'path' to open channel 'zipchan' + @cmd -name punk::zip::Addentry\ + -summary\ + "Add zip-entry for file at 'path'"\ + -help\ + "Add a single file at 'path' to open channel 'zipchan' return a central directory file record" @opts -comment -default "" -help "An optional comment specific to the added file" @@ -543,7 +547,7 @@ tcl::namespace::eval punk::zip { puts -nonewline $zipchan $ddesc } } - + #PK\x01\x02 Cdentral directory file header #set v1 0x0317 ;#upper byte 03 -> UNIX lower byte 23 -> 2.3 set v1 0x0017 ;#upper byte 00 -> MS_DOS and OS/2 (FAT/VFAT/FAT32 file systems) @@ -565,7 +569,10 @@ tcl::namespace::eval punk::zip { punk::args::define { @id -id ::punk::zip::mkzip @cmd -name punk::zip::mkzip\ - -help "Create a zip archive in 'filename'" + -summary\ + "Create a zip archive in 'filename'."\ + -help\ + "Create a zip archive in 'filename'" @opts -offsettype -default "archive" -choices {archive file}\ -help "zip offsets stored relative to start of entire file or relative to start of zip-archive diff --git a/src/modules/shellrun-0.1.1.tm b/src/modules/shellrun-0.1.1.tm index 81139307..802b45cc 100644 --- a/src/modules/shellrun-0.1.1.tm +++ b/src/modules/shellrun-0.1.1.tm @@ -249,7 +249,29 @@ namespace eval shellrun { dict incr ::tcl::UnknownOptions -level return -options $::tcl::UnknownOptions $::tcl::UnknownResult } + lappend PUNKARGS [list { + @id -id ::shellrun::runout + @leaders -min 0 -max 0 + @opts + -echo -type none + -nonewline -type none + -tcl -type none -default 0 + -debug -type none -default 0 + --timeout= -type integer + @values -min 1 -max -1 + cmdname -type string + cmdarg -type any -multiple 1 -optional 1 + }] proc runout {args} { + set argd [punk::args::parse $args withid ::shellrun::runout] + lassign [dict values $argd] leaders opts values received + + if {[dict exists $received "-nonewline"]} { + set nonewline 1 + } else { + set nonewline 0 + } + #set_last_run_display [list] variable runout variable runerr @@ -257,15 +279,10 @@ namespace eval shellrun { set runerr "" set RST [a] - set splitargs [get_run_opts $args] - set runopts [dict get $splitargs runopts] - set cmdargs [dict get $splitargs cmdargs] + #set splitargs [get_run_opts $args] + #set runopts [dict get $splitargs runopts] + #set cmdargs [dict get $splitargs cmdargs] - if {"-nonewline" in $runopts} { - set nonewline 1 - } else { - set nonewline 0 - } #puts stdout "RUNOUT cmdargs: $cmdargs" @@ -275,7 +292,7 @@ namespace eval shellrun { #set outvar_stackid [shellfilter::stack::add commandout tee_to_var -action float -settings {-varname ::runout}] # #when not echoing - use float-locked so that the repl's stack is bypassed - if {"-echo" in $runopts} { + if {[dict exists $received "-echo"]} { set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float-locked -settings {-varname ::shellrun::runout}] set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float-locked -settings {-varname ::shellrun::runerr}] #set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action sink-locked -settings {-varname ::shellrun::runerr}] @@ -284,10 +301,23 @@ namespace eval shellrun { set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -settings {-varname ::shellrun::runerr}] } - set callopts "" - if {"-tcl" in $runopts} { - append callopts " -tclscript 1" + set callopts [dict create] + if {[dict exists $received "-tcl"]} { + dict set callopts -tclscript 1 + } + if {[dict exists $received "-debug"]} { + dict set callopts -debug 1 + } + if {[dict exists $received --timeout]} { + dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash + } + set cmdname [dict get $values cmdname] + if {[dict exists $received cmdarg]} { + set cmdarglist [dict get $values cmdarg] + } else { + set cmdarglist {} } + set cmdargs [concat $cmdname $cmdarglist] #shellfilter::run [lrange $args 1 end] -teehandle punksh -outchan stdout -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none ] @@ -301,7 +331,7 @@ namespace eval shellrun { #shellfilter::stack::remove commandout $outvar_stackid if {[dict exists $exitinfo error]} { - if {"-tcl" in $runopts} { + if {[dict exists $received "-tcl"]} { } else { #we must raise an error. @@ -382,28 +412,61 @@ namespace eval shellrun { } } + lappend PUNKARGS [list { + @id -id ::shellrun::runerr + @leaders -min 0 -max 0 + @opts + -echo -type none + -nonewline -type none + -tcl -type none -default 0 + -debug -type none -default 0 + --timeout= -type integer + @values -min 1 -max -1 + cmdname -type string + cmdarg -type any -multiple 1 -optional 1 + }] proc runerr {args} { + set argd [punk::args::parse $args withid ::shellrun::runout] + lassign [dict values $argd] leaders opts values received + + if {[dict exists $received "-nonewline"]} { + set nonewline 1 + } else { + set nonewline 0 + } + #set_last_run_display [list] variable runout variable runerr set runout "" set runerr "" - set splitargs [get_run_opts $args] - set runopts [dict get $splitargs runopts] - set cmdargs [dict get $splitargs cmdargs] + #set splitargs [get_run_opts $args] + #set runopts [dict get $splitargs runopts] + #set cmdargs [dict get $splitargs cmdargs] - if {"-nonewline" in $runopts} { - set nonewline 1 + set callopts [dict create] + if {[dict exists $received "-tcl"]} { + dict set callopts -tclscript 1 + } + if {[dict exists $received "-debug"]} { + dict set callopts -debug 1 + } + if {[dict exists $received --timeout]} { + dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash + } + set cmdname [dict get $values cmdname] + if {[dict exists $received cmdarg]} { + set cmdarglist [dict get $values cmdarg] } else { - set nonewline 0 + set cmdarglist {} } + set cmdargs [concat $cmdname $cmdarglist] - set callopts "" - if {"-tcl" in $runopts} { + if {[dict exists $received "-tcl"]} { append callopts " -tclscript 1" } - if {"-echo" in $runopts} { + if {[dict exists $received "-echo"]} { set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float-locked -settings {-varname ::shellrun::runerr}] set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float-locked -settings {-varname ::shellrun::runout}] } else { diff --git a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/args.test b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/args.test index 7afb85fc..218f8fe2 100644 --- a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/args.test +++ b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/args.test @@ -265,4 +265,18 @@ namespace eval ::testspace { -result [list\ "RECEIVED_EXPECTED_ERROR" ] + + + test parse_withdef_parsekey_repeat_ordering {Ensure last flag has precedence}\ + -setup $common -body { + #It must always be possible to override earlier (non -multiple) options + set argd [punk::args::parse {-incr -decr -incr} withdef {@opts -type none -parsekey -direction} {-incr -typedefaults u} {-decr -typedefaults u}] + lappend result [dict get $argd opts] + }\ + -cleanup { + }\ + -result [list\ + {-direction u} + ] + } \ No newline at end of file diff --git a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/synopsis.test b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/synopsis.test index 99f145aa..c462b243 100644 --- a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/synopsis.test +++ b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/synopsis.test @@ -9,6 +9,8 @@ namespace eval ::testspace { } test synopsis_basic {test basic synopsis of punkargs definition}\ -setup $common -body { + #no @cmd -summary + #we still expect and require a leading line "# " in the synopsis namespace eval testns { punk::args::define { @id -id ::testspace::testns::t1 @@ -26,7 +28,7 @@ namespace eval ::testspace { namespace delete ::testspace::testns }\ -result [list\ - "::testspace::testns::t1 [a+ italic]a1[a] ?-o1 ? ?[a+ italic]v1[a]?" + "# \n::testspace::testns::t1 [a+ italic]a1[a+ noitalic] ?-o1 <[a+ italic]bool[a+ noitalic]>? ?[a+ italic]v1[a+ noitalic]?" ] test synopsis_basic_ensemble-like {test basic synopsis of punkargs ensemble-like definition}\ @@ -34,12 +36,14 @@ namespace eval ::testspace { namespace eval testns { punk::args::define { @id -id ::testspace::testns::t1 + @cmd -summary "summary" @leaders subcmd -default c1 -choices {c1 c2} @values -min 0 -max 0 } punk::args::define { @id -id "::testspace::testns::t1 c1" + @cmd -summary "summary" @values -min 0 -max 1 v1 -type string } @@ -52,9 +56,96 @@ namespace eval ::testspace { namespace delete ::testspace::testns }\ -result [list\ - "::testspace::testns::t1 ?[a+ italic]subcmd[a]?"\ - "::testspace::testns::t1 c1 [a+ italic]v1[a]" + "# summary\n::testspace::testns::t1 ?[a+ italic]subcmd[a+ noitalic]?"\ + "# summary\n::testspace::testns::t1 c1 [a+ italic]v1[a+ noitalic]" ] + test synopsis_alias_longopt_requiredval {}\ + -setup $common -body { + namespace eval testns { + punk::args::define { + @id -id ::testspace::testns::t1 + @cmd -summary summary + --verbose= -type int -default unreceived + } + } + lappend result [punk::ns::synopsis ::testspace::testns::t1] + #test that missing flag uses -default value + set argd [punk::args::parse {} withid ::testspace::testns::t1] + lappend result [dict get $argd opts] + #test prefix version of longopt accepts supplied int + set argd [punk::args::parse {--v=33} withid ::testspace::testns::t1] + lappend result [dict get $argd opts] + + if {[catch { + set argd [punk::args::parse {--v=} withid ::testspace::testns::t1] + } eMsg eOpts]} { + lappend result "expected-error1" + } else { + lappend result "missing-required-error1" + } + + if {[catch { + set argd [punk::args::parse {--v} withid ::testspace::testns::t1] + } eMsg eOpts]} { + lappend result "expected-error2" + } else { + lappend result "missing-required-error2" + } + + + }\ + -cleanup { + namespace delete ::testspace::testns + }\ + -result [list\ + "# summary\n::testspace::testns::t1 ?--verbose=<[a+ italic]int[a+ noitalic]>?"\ + {--verbose unreceived}\ + {--verbose 33}\ + expected-error1\ + expected-error2 + ] + + test synopsis_alias_longopt_optionalval {}\ + -setup $common -body { + namespace eval testns { + punk::args::define { + @id -id ::testspace::testns::t1 + @cmd -summary summary + --verbose= -type ?int? -default unreceived -typedefaults received + } + } + lappend result [punk::ns::synopsis ::testspace::testns::t1] + #test that missing flag uses -default value + set argd [punk::args::parse {} withid ::testspace::testns::t1] + lappend result [dict get $argd opts] + #test prefix version of longopt accepts supplied int + set argd [punk::args::parse {--v=33} withid ::testspace::testns::t1] + lappend result [dict get $argd opts] + if {[catch { + set argd [punk::args::parse {--v=} withid ::testspace::testns::t1] + } eMsg eOpts]} { + #expect fail due to received empty string failing + lappend result "expected-error1" + } else { + lappend result "missing-required-error1" + } + + #because the type is optional (?int?) - we expect the longopt to support solo operation. + #It should pick up the -typedefaults value as a default (not -default, which is for missing flag only) + set argd [punk::args::parse {--v} withid ::testspace::testns::t1] + lappend result [dict get $argd opts] + + }\ + -cleanup { + namespace delete ::testspace::testns + }\ + -result [list\ + "# summary\n::testspace::testns::t1 ?--verbose[a+ italic strike]?[a+ noitalic nostrike]=<[a+ italic]int[a+ noitalic]>[a+ italic strike]?[a+ noitalic nostrike]?"\ + {--verbose unreceived}\ + {--verbose 33}\ + expected-error1\ + {--verbose received} + ] } diff --git a/src/modules/textblock-999999.0a1.0.tm b/src/modules/textblock-999999.0a1.0.tm index 9a2b5823..f16c4476 100644 --- a/src/modules/textblock-999999.0a1.0.tm +++ b/src/modules/textblock-999999.0a1.0.tm @@ -137,11 +137,31 @@ tcl::namespace::eval textblock { return " -choices \{$choices\} -help {algorithm choice $choicemsg} " } } + namespace eval argdoc { + tcl::namespace::import ::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] + # -- --- --- --- --- + proc example {str} { + set str [string trimleft $str \n] + set block [punk::ansi::ansiwrap Web-gray [textblock::frame -ansibase [a+ Web-gray bold white] -ansiborder [a+ black White] -boxlimits {hl} -type block $str]] + set result [textblock::bookend_lines $block [a] "[a defaultbg] [a]"] + #puts $result + return $result + } + } + # hash_algorithm -optional 1 -choices {${[::textblock::argdoc::hash_algorithm_choices]}} -help\ # "algorithm choice" namespace eval argdoc { - set DYN_HASH_ALGORITHM_CHOICES_AND_HELP {$[::textblock::argdoc::hash_algorithm_choices_and_help]} + set DYN_HASH_ALGORITHM_CHOICES_AND_HELP {${[::textblock::argdoc::hash_algorithm_choices_and_help]}} punk::args::define { @dynamic @id -id ::textblock::use_hash @@ -7769,75 +7789,93 @@ tcl::namespace::eval textblock { # ${[textblock::frame_samples]} #todo punk::args alias for centre center etc? - punk::args::define { - @dynamic - @id -id ::textblock::frame - @cmd -name "textblock::frame"\ - -help "Frame a block of text with a border." - -checkargs -default 1 -type boolean\ - -help "If true do extra argument checks and - provide more comprehensive error info. - As the argument parser loads around 16 default frame - samples dynamically, this can add add up as each may - take 10s of microseconds. For many-framed tables - and other applications this can add up. - Set false for performance improvement." - -etabs -default 0\ - -help "expanding tabs - experimental/unimplemented." - -type -default light -choices {${[textblock::frametypes]}} -choicerestricted 0 -choicecolumns 8 -type dict\ - -choicelabels { - ${[textblock::frame_samples]} - }\ - -help "Type of border for frame." - -boxlimits -default {hl vl tlc blc trc brc} -type list -help "Limit the border box to listed elements. - passing an empty string will result in no box, but title/subtitle will still appear if supplied. - ${[textblock::EG]}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${[textblock::RST]}" - -boxmap -default {} -type dict - -joins -default {} -type list - -title -default "" -type string -regexprefail {\n}\ - -help "Frame title placed on topbar - no newlines. - May contain ANSI - no trailing reset required. - ${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing - e.g 2: frame -title [a+ red underline]MyThing${[textblock::RST]}" - -titlealign -default "centre" -choices {left centre right} - -subtitle -default "" -type string -regexprefail {\n}\ - -help "Frame subtitle placed on bottombar - no newlines - May contain Ansi - no trailing reset required." - -subtitlealign -default "centre" -choices {left centre right} - -width -default "" -type int\ - -help "Width of resulting frame including borders. - If omitted or empty-string, the width will be determined automatically based on content." - -height -default "" -type int\ - -help "Height of resulting frame including borders." - -ansiborder -default "" -type ansistring\ - -help "Ansi escape sequence to set border attributes. - ${[textblock::EG]}e.g 1: frame -ansiborder [a+ web-red] contents - e.g 2: frame -ansiborder \"\\x1b\\\[31m\" contents${[textblock::RST]}" - -ansibase -default "" -type ansistring\ - -help "Default ANSI attributes within frame." - -blockalign -default centre -choices {left right centre}\ - -help "Alignment of the content block within the frame." - -pad -default 1 -type boolean -help "Whether to pad within the ANSI so content background - extends within the content block inside the frame. - Has no effect if no ANSI in content." - -textalign -default left -choices {left right centre}\ - -help "Alignment of text within the content block. (centre unimplemented)" - -ellipsis -default 1 -type boolean\ - -help "Whether to show elipsis for truncated content and title/subtitle." - -usecache -default 1 -type boolean - -buildcache -default 1 -type boolean - -crm_mode -default 0 -type boolean\ - -help "Show ANSI control characters within frame contents. - (Control Representation Mode) - Frame width doesn't adapt and content may be truncated - so -width may need to be manually set to display more." + namespace eval argdoc { + punk::args::define { + @dynamic + @id -id ::textblock::frame + @cmd -name "textblock::frame"\ + -summary "Frame a block of content with a border."\ + -help\ + "This command allows content to be framed with various border styles. The content can include + other ANSI codes and unicode characters. Some predefined border types can be selected with + the -type option and the characters can be overridden either in part or in total by supplying + some or all entries in the -boxmap dictionary. + The ${$B}textblock::framedef${$N} command can be used to return a dictionary for a frame type. + Border elements can also be suppressed on chosen sides with -boxlimits. + ANSI colours can be applied to borders or as defaults for the content using -ansiborder and + -ansibase options. + The punk::ansi::a+ function (aliased as a+) can be used to apply ANSI styles. + e.g + frame -type block -ansiborder [a+ blue Red] -ansibase [a+ black Red] \"A\\nB\"" + -checkargs -default 1 -type boolean\ + -help "If true do extra argument checks and + provide more comprehensive error info. + As the argument parser loads around 16 default frame + samples dynamically, this can add add up as each may + take 10s of microseconds. For many-framed tables + and other applications this can add up. + Set false for performance improvement." + -etabs -default 0\ + -help "expanding tabs - experimental/unimplemented." + -type -default light\ + -type dict\ + -typesynopsis {${$I}choice${$NI}|<${$I}dict${$NI}>}\ + -choices {${[textblock::frametypes]}}\ + -choicerestricted 0 -choicecolumns 8\ + -choicelabels { + ${[textblock::frame_samples]} + }\ + -help "Type of border for frame." + -boxlimits -default {hl vl tlc blc trc brc} -type list -help "Limit the border box to listed elements. + passing an empty string will result in no box, but title/subtitle will still appear if supplied. + ${[textblock::EG]}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${[textblock::RST]}" + -boxmap -default {} -type dict + -joins -default {} -type list + -title -default "" -type string -regexprefail {\n}\ + -help "Frame title placed on topbar - no newlines. + May contain ANSI - no trailing reset required. + ${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing + e.g 2: frame -title [a+ red underline]MyThing${[textblock::RST]}" + -titlealign -default "centre" -choices {left centre right} + -subtitle -default "" -type string -regexprefail {\n}\ + -help "Frame subtitle placed on bottombar - no newlines + May contain Ansi - no trailing reset required." + -subtitlealign -default "centre" -choices {left centre right} + -width -default "" -type int\ + -help "Width of resulting frame including borders. + If omitted or empty-string, the width will be determined automatically based on content." + -height -default "" -type int\ + -help "Height of resulting frame including borders." + -ansiborder -default "" -type ansistring\ + -help "Ansi escape sequence to set border attributes. + ${[textblock::EG]}e.g 1: frame -ansiborder [a+ web-red] contents + e.g 2: frame -ansiborder \"\\x1b\\\[31m\" contents${[textblock::RST]}" + -ansibase -default "" -type ansistring\ + -help "Default ANSI attributes within frame." + -blockalign -default centre -choices {left right centre}\ + -help "Alignment of the content block within the frame." + -pad -default 1 -type boolean -help "Whether to pad within the ANSI so content background + extends within the content block inside the frame. + Has no effect if no ANSI in content." + -textalign -default left -choices {left right centre}\ + -help "Alignment of text within the content block. (centre unimplemented)" + -ellipsis -default 1 -type boolean\ + -help "Whether to show elipsis for truncated content and title/subtitle." + -usecache -default 1 -type boolean + -buildcache -default 1 -type boolean + -crm_mode -default 0 -type boolean\ + -help "Show ANSI control characters within frame contents. + (Control Representation Mode) + Frame width doesn't adapt and content may be truncated + so -width may need to be manually set to display more." - @values -min 0 -max 1 - contents -default "" -type string\ - -help "Frame contents - may be a block of text containing newlines and ANSI. - Text may be 'ragged' - ie unequal line-lengths. - No trailing ANSI reset required. - ${[textblock::EG]}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${[textblock::RST]}" + @values -min 0 -max 1 + contents -default "" -type string\ + -help "Frame contents - may be a block of text containing newlines and ANSI. + Text may be 'ragged' - ie unequal line-lengths. + No trailing ANSI reset required. + ${[textblock::EG]}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${[textblock::RST]}" + } } #options before content argument - which is allowed to be absent