Browse Source

add 'mash options' aka 'option clustering' aka 'short flag stacking'

master
Julian Noble 2 weeks ago
parent
commit
8dfae55673
  1. 537
      src/bootsupport/modules/punk/args-0.2.1.tm
  2. 2
      src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm
  3. 19
      src/bootsupport/modules/punk/nav/ns-0.1.0.tm
  4. 148
      src/bootsupport/modules/punk/repo-0.1.1.tm
  5. 537
      src/modules/punk/args-999999.0a1.0.tm
  6. 2
      src/modules/punk/args/moduledoc/tclcore-999999.0a1.0.tm
  7. 19
      src/modules/punk/nav/ns-999999.0a1.0.tm
  8. 148
      src/modules/punk/repo-999999.0a1.0.tm
  9. 225
      src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/mashopts.test
  10. 0
      src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/tests/mashopts.test#..+args+mashopts.test.fauxlink
  11. 537
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm
  12. 2
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm
  13. 19
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/ns-0.1.0.tm
  14. 148
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm
  15. 537
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm
  16. 2
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm
  17. 19
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/ns-0.1.0.tm
  18. 148
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm
  19. 537
      src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm
  20. 2
      src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tclcore-0.1.0.tm
  21. 19
      src/vfs/_vfscommon.vfs/modules/punk/nav/ns-0.1.0.tm
  22. 148
      src/vfs/_vfscommon.vfs/modules/punk/repo-0.1.1.tm
  23. BIN
      src/vfs/_vfscommon.vfs/modules/test/punk/args-0.1.5.tm

537
src/bootsupport/modules/punk/args-0.2.1.tm

@ -665,6 +665,8 @@ tcl::namespace::eval punk::args {
%B%@opts%N% ?opt val...? %B%@opts%N% ?opt val...?
directive-options: -any|-arbitrary <bool> directive-options: -any|-arbitrary <bool>
(also accepts options as defaults for subsequent flag definitions) (also accepts options as defaults for subsequent flag definitions)
e.g -mash 1 - default to single letter flags to be mashable/combinable
(-abc instead of -a -b -c)
%B%@values%N% ?opt val...? %B%@values%N% ?opt val...?
(used for trailing args that come after switches/opts) (used for trailing args that come after switches/opts)
directive-options: -min <int> -max <int> -unnamed <bool> directive-options: -min <int> -max <int> -unnamed <bool>
@ -813,6 +815,22 @@ tcl::namespace::eval punk::args {
Further unambiguous arrangements of optional args may be Further unambiguous arrangements of optional args may be
made in future - but are currently considered 'unsupported' made in future - but are currently considered 'unsupported'
-default <value> -default <value>
-mash <bool> (for flags/switches only)
Option clustering, flag stacking, option mashing
- all refer to the same thing:
Whether single letter flags can be mashed together.
E.g -abc instead of -a -b -c
This defaults to false, but can be set to true for all
single-letter flags by setting -mash true on the @opts directive.
It is an error to explicitly set -mash true on a flag that doesn't
have a single letter as part it's name.
(e.g it is ok on -f or even -f|--flag)
When such flags are combined, only the last one can take a value.
E.g with -mash true and flags -a -b and -c that take no values,
and -f that takes a value:
-abc is valid and equivalent to -a -b -c
-abcf <value> is valid and equivalent to -a -b -c -f <value>
but -afc <value> is not valid
-multiple <bool> (for leaders & values defines whether -multiple <bool> (for leaders & values defines whether
subsequent received values are stored against the same subsequent received values are stored against the same
argument name - only applies to final leader OR final value) argument name - only applies to final leader OR final value)
@ -1008,6 +1026,7 @@ tcl::namespace::eval punk::args {
-validate_ansistripped 0\ -validate_ansistripped 0\
-strip_ansi 0\ -strip_ansi 0\
-nocase 0\ -nocase 0\
-mash 0\
-choiceprefix 1\ -choiceprefix 1\
-choicerestricted 1\ -choicerestricted 1\
-choicemultiple {1 1}\ -choicemultiple {1 1}\
@ -1065,6 +1084,8 @@ tcl::namespace::eval punk::args {
OPT_MIN ""\ OPT_MIN ""\
OPT_MAX ""\ OPT_MAX ""\
OPT_SOLOS {}\ OPT_SOLOS {}\
OPT_MASHES {}\
OPT_ALL_MASH_LETTERS {}\
OPTSPEC_DEFAULTS $optdirective_defaults\ OPTSPEC_DEFAULTS $optdirective_defaults\
OPT_CHECKS_DEFAULTS {}\ OPT_CHECKS_DEFAULTS {}\
OPT_GROUPS {}\ OPT_GROUPS {}\
@ -1548,15 +1569,18 @@ tcl::namespace::eval punk::args {
"" - # {continue} "" - # {continue}
} }
incr record_number incr record_number
if {[catch {lassign $trimrec firstword}]} { #after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict
if {[catch {set record_values [lassign $trimrec firstword]}]} {
puts stdout "----------------------------------------------" puts stdout "----------------------------------------------"
puts stderr "rec: $rec" puts stderr "rec: $rec"
set ::testrecord $rec set ::testrecord $rec
puts stdout "----------------------------------------------" puts stdout "----------------------------------------------"
puts "records: $records" puts "records: $records"
puts stdout "==============================================" puts stdout "=============================================="
error "punk::args::resolve - bad optionspecs line - unable to parse first word of record '$trimrec' id:$DEF_definition_id"
} }
set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict #set record_values [lassign $trimrec firstword]
if {[llength $record_values] % 2 != 0} { if {[llength $record_values] % 2 != 0} {
#todo - avoid raising an error - store invalid defs keyed on id #todo - avoid raising an error - store invalid defs keyed on id
error "punk::args::resolve - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" error "punk::args::resolve - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id"
@ -1808,6 +1832,14 @@ tcl::namespace::eval punk::args {
#set opt_any $v #set opt_any $v
tcl::dict::set F $fid OPT_ANY $v tcl::dict::set F $fid OPT_ANY $v
} }
-mash {
#default for single letter options that can be mashed together - e.g -a -b can be supplied as -ab if -mash is 1
#check is bool
if {![string is boolean -strict $v]} {
error "punk::args::resolve - Option '$k' has value '$v'of wrong type in @opts line. Must be boolean @id:$DEF_definition_id"
}
tcl::dict::set tmp_optspec_defaults $k $v
}
-min { -min {
dict set F $fid OPT_MIN $v dict set F $fid OPT_MIN $v
} }
@ -1918,7 +1950,7 @@ tcl::namespace::eval punk::args {
} }
default { default {
set known { -parsekey -group -grouphelp\ set known { -parsekey -group -grouphelp\
-any -anyopts -arbitrary -form -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo\ -any -anyopts -mash -arbitrary -form -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo\
-type -range -typeranges -default -defaultdisplaytype -typedefaults -type -range -typeranges -default -defaultdisplaytype -typedefaults
-choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted -nocase\ -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted -nocase\
-unindentedfields\ -unindentedfields\
@ -2402,6 +2434,8 @@ tcl::namespace::eval punk::args {
foreach fid $record_form_ids { foreach fid $record_form_ids {
if {$is_opt} { if {$is_opt} {
#OPTSPEC_DEFAULTS are the base defaults for options - these can be overridden by @opts lines
#we may still need to test some of these defaults for validity, e.g -mash true can only apply if the argname has at least one single-character alias (e.g -x or -x|--xxx)
set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS] set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS]
} else { } else {
if {[dict get $F $fid argspace] eq "values"} { if {[dict get $F $fid argspace] eq "values"} {
@ -2518,6 +2552,25 @@ tcl::namespace::eval punk::args {
-parsekey - -group { -parsekey - -group {
tcl::dict::set spec_merged -typesynopsis $specval tcl::dict::set spec_merged -typesynopsis $specval
} }
-mash {
#allow when any alt in argname is a single letter flag such s -a or -Z
#single letter flags do not have to be -type none to allow -mash to be set true.
#a mash can be supplied where the last flag in the mash is a value-taking flag.
if {$specval} {
set has_single_letter_flag 0
foreach alias $optaliases {
if {[string length $alias] == 2 && [string match -* $alias]} {
set has_single_letter_flag 1
break
}
}
if {!$has_single_letter_flag} {
error "punk::args::resolve - invalid use of -mash for argument '$argname'. -mash can only be true if at least one alias in the argname is a single-letter flag (e.g -a or -Z) @id:$DEF_definition_id"
#todo - we also have to set -mash false when processing defaults from @opts if the argname doesn't contain any single-letter flags
}
}
tcl::dict::set spec_merged -mash $specval
}
-unindentedfields - -unindentedfields -
-solo - -solo -
-choices - -choicegroups - -choicemultiple - -choicecolumns - -choices - -choicegroups - -choicemultiple - -choicecolumns -
@ -2661,6 +2714,30 @@ tcl::namespace::eval punk::args {
if {[tcl::dict::get $spec_merged -type] eq "none"} { if {[tcl::dict::get $spec_merged -type] eq "none"} {
dict set F $fid OPT_SOLOS [list {*}[dict get $F $fid OPT_SOLOS] $argname] dict set F $fid OPT_SOLOS [list {*}[dict get $F $fid OPT_SOLOS] $argname]
} }
if {[tcl::dict::get $spec_merged -mash]} {
#The value for -mash might be true only due to a default from @opts - in which case we need to check the argname for validity of -mash as described above and if not valid, set -mash false in the ARG_INFO for this argname
if {$argname eq "--"} {
#force -mash false - in case no -mash was specified on the flag itself and @opts -mash is true
tcl::dict::set spec_merged -mash false
} else {
set has_single_letter_flag 0
foreach alias $optaliases {
if {[string length $alias] == 2 && [string match -* $alias]} {
set has_single_letter_flag 1
break
}
}
if {!$has_single_letter_flag} {
#force -mash false in ARG_INFO for this argname - in case no -mash was specified and @opts -mash is true by default but argname doesn't contain any single-letter flags
tcl::dict::set spec_merged -mash false
}
}
#re-test state of -mash after any adjustments based on argname validity and defaults
if {[tcl::dict::get $spec_merged -mash]} {
#we add the whole argname with all aliases to the OPT_MASHES list - this is used during parsing to check if any of the aliases for a given flag are mashable
dict set F $fid OPT_MASHES [list {*}[dict get $F $fid OPT_MASHES] $argname]
}
}
} else { } else {
tcl::dict::set F $fid ARG_CHECKS $argname\ tcl::dict::set F $fid ARG_CHECKS $argname\
[tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi -choicecolumns -group -typesynopsis -help -ARGTYPE] ;#leave things like -range -minsize [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi -choicecolumns -group -typesynopsis -help -ARGTYPE] ;#leave things like -range -minsize
@ -2716,6 +2793,21 @@ tcl::namespace::eval punk::args {
#now cycle through ALL forms not just form_ids_active (record_form_ids) #now cycle through ALL forms not just form_ids_active (record_form_ids)
dict for {fid formdata} $F { dict for {fid formdata} $F {
set mashargs [dict get $F $fid OPT_MASHES]
if {[llength $mashargs]} {
#precalculate OPT_ALL_MASH_LETTERS
set all_mash_letters [list]
foreach fullopt $mashargs {
foreach flagpart [split $fullopt |] {
if {[string length $flagpart] == 2 && [string match -* $flagpart]} {
lappend all_mash_letters [string index $flagpart 1]
}
}
}
dict set F $fid OPT_ALL_MASH_LETTERS $all_mash_letters
}
if {[tcl::dict::get $F $fid OPT_MAX] eq ""} { if {[tcl::dict::get $F $fid OPT_MAX] eq ""} {
if {[llength [tcl::dict::get $F $fid OPT_NAMES]] == 0 && ![tcl::dict::get $F $fid OPT_ANY]} { if {[llength [tcl::dict::get $F $fid OPT_NAMES]] == 0 && ![tcl::dict::get $F $fid OPT_ANY]} {
tcl::dict::set F $fid OPT_MAX 0 ;#aid in parsing to avoid scanning for opts unnecessarily tcl::dict::set F $fid OPT_MAX 0 ;#aid in parsing to avoid scanning for opts unnecessarily
@ -3292,8 +3384,8 @@ tcl::namespace::eval punk::args {
return true return true
} }
foreach d $rawdef { foreach d $rawdef {
if {[regexp {\s*(\S+)} $d _match firstword]} { if {[regexp {\s*(\S+)} $d _match first_rawdef_word]} {
if {$firstword eq "@dynamic"} { if {$first_rawdef_word eq "@dynamic"} {
return true return true
} }
} }
@ -3513,7 +3605,7 @@ tcl::namespace::eval punk::args {
} }
# -- --- --- --- --- --- # -- --- --- --- --- ---
set unscanned [punklib_ldiff $registered $scanned_packages] set unscanned [punk::args::system::punklib_ldiff $registered $scanned_packages]
if {[llength $unscanned]} { if {[llength $unscanned]} {
foreach pkgns $unscanned { foreach pkgns $unscanned {
set idcount 0 set idcount 0
@ -3562,7 +3654,7 @@ tcl::namespace::eval punk::args {
if {"*" in $nslist} { if {"*" in $nslist} {
set needed [punklib_ldiff $registered $loaded_packages] set needed [punk::args::system::punklib_ldiff $registered $loaded_packages]
} else { } else {
set needed [list] set needed [list]
foreach pkgns $nslist { foreach pkgns $nslist {
@ -4311,6 +4403,33 @@ tcl::namespace::eval punk::args {
set trie [punk::trie::trieclass new {*}$all_opts --] set trie [punk::trie::trieclass new {*}$all_opts --]
set idents [dict get [$trie shortest_idents ""] scanned] set idents [dict get [$trie shortest_idents ""] scanned]
if {[llength [dict get $form_dict OPT_MASHES]]} {
set all_mash_letters [dict get $form_dict OPT_ALL_MASH_LETTERS]
#now extend idents to be at least as long as the number of mash/bundle flags that exist.
#(when the flag itself is longer than number of mash flags
# - e.g for flags -x -v -c -f -collection, the ident for -collection would be -co normally
# but if we have 4 mash flags, we want it to be -colle to satisfy the requirement that it is longer then the number of mash flags
# unless it is an exact match.)
#
#e.g if all the single letter flags are configured with -mash true:
#our prefix calculation might give us the following idents:
# idents: -cabinet -ca -a -a -b -b -c -c -- --
#we need only to extend -cabinet to -cabi to satisfy the requirement that it is longer than the number of mash flags (3 in this example because -- is never a mash flag)
dict for {fullname ident} $idents {
set mashcount [llength $all_mash_letters]
#assert: if we are here - mashcount > 0
if {[string length $ident] < [string length $fullname] && [string length $ident] <= $mashcount} {
dict set idents $fullname [string range $fullname 0 $mashcount+1]
}
}
#note it's still possible for the user to define a flag with a name shorter than the number of mash flags
# and it could even overlap with a specific combination of mash letters - e.g -a -b -c -d and a flag named -bac
# - in this case a provided value of -bac would still match the flag -bac rather than being treated as a mash of -b -a -c
#because the exact match will take priority over the prefix match.
#Whilst this configuration is accepted - it's not recommended.
}
#todo - check opt_prefixdeny #todo - check opt_prefixdeny
$trie destroy $trie destroy
@ -7906,6 +8025,8 @@ tcl::namespace::eval punk::args {
#set OPT_MIN [dict get $formdict OPT_MIN] #set OPT_MIN [dict get $formdict OPT_MIN]
set OPT_MAX [dict get $formdict OPT_MAX] set OPT_MAX [dict get $formdict OPT_MAX]
#set OPT_SOLOS [dict get $formdict OPT_SOLOS] #set OPT_SOLOS [dict get $formdict OPT_SOLOS]
set OPT_MASHES [dict get $formdict OPT_MASHES]
set OPT_ALL_MASH_LETTERS [dict get $formdict OPT_ALL_MASH_LETTERS]
set OPTSPEC_DEFAULTS [dict get $formdict OPTSPEC_DEFAULTS] set OPTSPEC_DEFAULTS [dict get $formdict OPTSPEC_DEFAULTS]
set OPT_CHECKS_DEFAULTS [dict get $formdict OPT_CHECKS_DEFAULTS] set OPT_CHECKS_DEFAULTS [dict get $formdict OPT_CHECKS_DEFAULTS]
#set OPT_GROUPS [dict get $formdict OPT_GROUPS] #set OPT_GROUPS [dict get $formdict OPT_GROUPS]
@ -7956,8 +8077,11 @@ tcl::namespace::eval punk::args {
} }
} }
} }
#note all_opts will necessarily not include mashed flags (e.g -abc) when only -a -b -c are defined - but we will detect and break those down in the main loop below
set all_opts [dict keys $lookup_optset] set all_opts [dict keys $lookup_optset]
set ridx 0 set ridx 0
set rawargs_copy $rawargs set rawargs_copy $rawargs
set remaining_rawargs $rawargs set remaining_rawargs $rawargs
@ -8374,15 +8498,225 @@ tcl::namespace::eval punk::args {
#flagsupplied when --longopt=x is --longopt (may still be a prefix) #flagsupplied when --longopt=x is --longopt (may still be a prefix)
#get full flagname from possible prefix $flagsupplied #get full flagname from possible prefix $flagsupplied
set flagname [tcl::prefix match -error "" [list {*}$all_opts --] $flagsupplied] set flagname [tcl::prefix match -error "" [list {*}$all_opts --] $flagsupplied]
if {$flagname eq "--"} { #The prefix matching above doesn't consider that mashed flags can make shorter prefixes an invalid match for the whole flag.
set optionset "" #if the length of our matched flagname is less than the length of $OPT_ALL_MASH_LETTERS, then we may have a mash of other flags,
} else { #not a valid match for some longer flag that just happens to share the same prefix as the start of the mash.
if {[dict exists $lookup_optset $flagname]} { #we have defined valid prefix matches in the presence of mashed flags to be only those that are longer than any possible mash of flags
set optionset [dict get $lookup_optset $flagname]
} else { #(review - for small numbers of mashed flags we could be more precise, but the combinatoric explosion of longer mash lengths makes it
#simpler to just say any match that is shorter than the length of the longest possible mash is invalid
# we may need consider what common utilities do in practice regarding allowing prefixes in the presence of mashed flags
#- but it seems likely that they would either not allow prefixes at all, or only allow prefixes that are longer than any possible mash of flags)
#So if we have a match that isn't exact and is shorter than the length of the longest possible mash, we need to check if it's actually a mash of valid flags rather than a valid prefix match for a longer flag.
if {$flagname ne $flagsupplied && [llength $OPT_MASHES] && (([string length $flagsupplied] -1) <= [llength $OPT_ALL_MASH_LETTERS])} {
#invalidate the match
set flagname ""
}
switch -- $flagname {
-- {
set optionset "" set optionset ""
} }
"" {
#no match for flagname - could be a mashed flag e.g -abc where only -a -b -c are defined
if {![llength $OPT_MASHES]} {
#no mashed flags defined - so this probably isn't a flag - could be a value
set optionset ""
} else {
#check if every letter after the first matches a defined opt - if so treat as mashed flags
set mashflags [string range $flagsupplied 1 end]
set mashletters [split $mashflags ""]
set all_mashable true
foreach mf $mashletters {
if {$mf ni $OPT_ALL_MASH_LETTERS} {
set all_mashable false
break
}
}
#todo - move block below up here.
if {!$all_mashable} {
puts stderr "Debug: flagsupplied '$flagsupplied' not a valid flagname and not a valid mash of flags - treating as value"
#- probably isn't a flag at all - could be a value
#treat as value
set optionset ""
} else {
#puts stderr "Debug: flagsupplied '$flagsupplied' not a valid flagname but is a valid mash of flags - treating as mash of flags"
#treat as mashed flags - we will break down into individual flags and process each one in turn
set optionset $flagsupplied
#the -mash option means we may have to process multiple flags as received for one arg that looks like a flag
#we can still use the lookup_optset dict to get the optionset for each individual flag - as the keys of lookup_optset are all the individual flags (not mashed together)
#we need to update:
# vals_remaining_possible after processing all matchletters (by -1 or -2 depending on whether the mash includes a flag with an attached value (trailing=<val>) or accepts a value.)
# multisreceived
# soloreceived (if any of the flags in the mash are solo)
# flagsreceived (add the mash as received - but also add each individual flag in the mash as received for the purposes of checking for multiple and solo)
# opts (for each flag in the mash)
set posn 0
set consume_value 0 ;#if last mash flag accepts a value, we will consume the next arg as its value
foreach mf $mashletters {
set matchopt [dict get $lookup_optset -$mf]
if {$matchopt eq ""} {
#this should not happen as we have already checked all letters are mashable - but check just in case
puts stderr "Debug: mash letter '-$mf' not in lookup_optset - this should not happen"
} else {
#process each mashed flag as if it were received separately
#- we can reuse the same flagval for each as they won't be expected to have values (as they are single letter flags)
#we will still need to check for multiple and defaults for each individual flag
#we can also still use the same argstate entries for each individual flag as the optionset will be the same for each of the mashed flags (as they will all be defined in the same optionset e.g -a|-b|-c)
set mashflagname -$mf
set mashflagoptionset [dict get $lookup_optset $mashflagname]
set raw_optionset_members [split $mashflagoptionset |]
#set mashflagapiopt [dict get $argstate $mashflagoptionset -parsekey]
#if {$mashflagapiopt eq ""} {
# set mashflagapiopt [string trimright [lindex [split $mashflagoptionset |] end] =]
#}
set flagname -$mf
if {[tcl::dict::get $argstate $mashflagoptionset -parsekey] ne ""} {
set api_opt [dict get $argstate $mashflagoptionset -parsekey]
} else {
set api_opt [string trimright [lindex $raw_optionset_members end] =]
}
if {$api_opt eq $flagname} {
set flag_ident $api_opt
set flag_ident_is_parsekey 0
} else {
#initially key our opts on a long form allowing us to know which specific flag was used
#(for when multiple map to same parsekey e.g lsearch)
#e.g -increasing|-SORTOPTION
set flag_ident $flagname|$api_opt
set flag_ident_is_parsekey 1
}
set optionset_type [tcl::dict::get $argstate $mashflagoptionset -type]
#only the last flag in a mash can be allowed to have a value, and the other flags must be of type none.
#flags are by default optional.
if {$optionset_type ne "none"} {
#A flag with a value - only allowed for the last flag in a mash
if {$posn != [expr {[llength $mashletters] - 1}]} {
#not the last flag in the mash - can't have a value
set errmsg "bad options for %caller%. Flag \"$mashflagname\" in mash \"$flagsupplied\" cannot have a value as only the last flag in a mash can have a value. The flag \"$mashflagname\" must be of type none. (1)"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $all_opts] -badarg $a -argspecs $argspecs]] $errmsg
} else {
set consume_value 1
# ------------
#check if it was actually a value that looked like a flag
if {$i == $maxidx} {
#if no optvalue following - assume it's a value
#(caller should probably have used -- before it)
#review
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
break
}
#flagval comes from next remaining rawarg
set flagval [lindex $remaining_rawargs $i+1]
if {[tcl::dict::get $argstate $mashflagoptionset -multiple]} {
#don't lappend to default - we need to replace if there is a default
if {$api_opt ni $flagsreceived} {
tcl::dict::set opts $flag_ident [list $flagval]
} else {
tcl::dict::lappend opts $flag_ident $flagval
}
if {$api_opt ni $multisreceived} {
lappend multisreceived $api_opt
}
} else {
#tcl::dict::set opts $flag_ident $flagval
if {$flag_ident_is_parsekey} {
#necessary shimmer ?
lappend opts $flag_ident $flagval
} else {
tcl::dict::set opts $flag_ident $flagval
}
}
#incr i to skip flagval
#incr vals_remaining_possible -2
#if {[incr i] > $maxidx} {
# set msg "Bad options for %caller%. No value supplied for last option $mashflagoptionset at index [expr {$i-1}] which is not marked with -type none"
# return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $mashflagoptionset index [expr {$i-1}]] -badarg $mashflagoptionset -argspecs $argspecs]] $msg
#}
# ------------
}
} else {
#flag with no value - check for -typedefaults for the flag
#none / solo
if {[tcl::dict::exists $argstate $mashflagoptionset -typedefaults]} {
set tdflt [tcl::dict::get $argstate $mashflagoptionset -typedefaults]
} else {
#normal default for a solo is 1 unless overridden by -typedefaults
set tdflt 1
}
if {[tcl::dict::get $argstate $mashflagoptionset -multiple]} {
#puts stderr "Debug: flag '$mashflagname' in mash '$flagsupplied' is a multiple with typedefaults $tdflt -- api_opt: $api_opt flag_ident: $flag_ident flagsreceived: $flagsreceived multisreceived: $multisreceived"
if {$api_opt ni $flagsreceived} {
#override any default - don't lappend to it
tcl::dict::set opts $flag_ident $tdflt
} else {
tcl::dict::lappend opts $flag_ident $tdflt
}
if {$api_opt ni $multisreceived} {
lappend multisreceived $api_opt
}
} else {
#test parse_withdef_parsekey_repeat_ordering {Ensure last flag has precedence}
#tcl::dict::set opts $flag_ident $tdflt
if {$flag_ident_is_parsekey} {
#(shimmer - but required for ordering correctness during override)
puts stderr "Debug: flag '$mashflagname' in mash '$flagsupplied' flag_ident '$flag_ident' is the same as parsekey '$api_opt' tdflt: $tdflt - using lappend to ensure it ends up after any previous flag in the mash that had the same parsekey"
lappend opts $flag_ident $tdflt
puts stderr "opts after lappend: $opts"
} else {
tcl::dict::set opts $flag_ident $tdflt
}
}
#incr vals_remaining_possible -1
lappend solosreceived $api_opt ;#dups ok
}
}
lappend flagsreceived $api_opt
incr posn
}
#update vals_remaining_possible by one or 2 if the last flag took a value.
incr vals_remaining_possible -1
if {$flagval_included || $consume_value} {
incr vals_remaining_possible -1
}
#after processing the mash, we will have updated opts for each individual flag in the mash,
#and updated multisreceived and solo_received as needed based on the optionset entries for each individual flag in the mash
#we possibly need to incr i to skip a received value for the mash if the last flag in the mash had a value.
#or break if we have reached the end of the args after processing the mash
if {$flagval_included || $consume_value} {
#the last flag in the mash had a value - we have already processed it for that flag - so we need to skip it for the next iteration of the loop
incr i
if {$i > $maxidx} {
#we have reached the end of the args after processing the mash and its value - so we can break out of the loop
break
}
} else {
#no value included for the last flag in the mash - so we just continue to the next iteration of the loop to process the next arg
}
continue
}
}
}
default {
if {[dict exists $lookup_optset $flagname]} {
set optionset [dict get $lookup_optset $flagname]
} else {
#we matched a prefix of all_opts - but it's not in the lookup_optset?
#review - this should not happen as we only match prefixes from all_opts which is derived from the keys of lookup_optset
puts stderr "Debug: matched prefix '$flagname' not in lookup_optset - this should not happen"
set optionset ""
}
}
} }
if {$optionset ne ""} { if {$optionset ne ""} {
#matched some option - either in part or in full. #matched some option - either in part or in full.
set raw_optionset_members [split $optionset |] set raw_optionset_members [split $optionset |]
@ -9205,7 +9539,7 @@ tcl::namespace::eval punk::args {
#} #}
#for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us
if {[llength $LEADER_REQUIRED]} { if {[llength $LEADER_REQUIRED]} {
if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { if {[llength [set missing [punk::args::system::punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} {
set msg "Required leader missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" 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 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 #arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs
@ -9213,7 +9547,7 @@ tcl::namespace::eval punk::args {
} }
if {[llength $OPT_REQUIRED]} { if {[llength $OPT_REQUIRED]} {
set api_opt_required [lmap v $OPT_REQUIRED {lindex [split $v |] end}] set api_opt_required [lmap v $OPT_REQUIRED {lindex [split $v |] end}]
if {[llength [set missing [punklib_ldiff $api_opt_required $flagsreceived]]]} { if {[llength [set missing [punk::args::system::punklib_ldiff $api_opt_required $flagsreceived]]]} {
set full_missing [list] set full_missing [list]
foreach m $missing { foreach m $missing {
lappend full_missing [dict get $lookup_optset $m] lappend full_missing [dict get $lookup_optset $m]
@ -9225,7 +9559,7 @@ tcl::namespace::eval punk::args {
} }
} }
if {[llength $VAL_REQUIRED]} { if {[llength $VAL_REQUIRED]} {
if {[llength [set missing [punklib_ldiff $VAL_REQUIRED $valnames_received]]]} { if {[llength [set missing [punk::args::system::punklib_ldiff $VAL_REQUIRED $valnames_received]]]} {
set msg "Required value missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" 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 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 #arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs
@ -10026,8 +10360,8 @@ tcl::namespace::eval punk::args {
set alternates [list];#alternate acceptable types e.g literal(yes)|literal(ok) or indexpression|literal(first) set alternates [list];#alternate acceptable types e.g literal(yes)|literal(ok) or indexpression|literal(first)
set type_alternatives [_split_type_expression $tp] set type_alternatives [_split_type_expression $tp]
foreach tp_alternative $type_alternatives { foreach tp_alternative $type_alternatives {
set firstword [lindex $tp_alternative 0] set tp_alternative_word1 [lindex $tp_alternative 0]
switch -exact -- $firstword { switch -exact -- $tp_alternative_word1 {
literal { literal {
set match [lindex $tp_alternative 1] set match [lindex $tp_alternative 1]
lappend alternates $match lappend alternates $match
@ -11485,7 +11819,7 @@ tcl::namespace::eval punk::args::package {
-return\ -return\
-type string\ -type string\
-default table\ -default table\
-choices {string table tableobject}\ -choices {string table tableobject dict}\
-choicelabels { -choicelabels {
string\ string\
"A basic text layout" "A basic text layout"
@ -11564,19 +11898,25 @@ tcl::namespace::eval punk::args::package {
} }
} }
} }
if {$opt_return ne "string"} {
package require textblock ;#table support
set is_table 1
set title [string cat {[} $pkgname {]} ]
set t [textblock::class::table new -title $title]
$t configure -frametype double -minwidth [expr {[string length $title]+2}]
} else { set is_table 0
set topiclens [lmap t $topics {string length $t}] switch -- $opt_return {
set widest_topic [tcl::mathfunc::max {*}$topiclens] table - tableobject {
set is_table 0 package require textblock ;#table support
set about "$pkgname\n" set is_table 1
append about [string repeat - $widest_topic] \n set title [string cat {[} $pkgname {]} ]
set t [textblock::class::table new -title $title]
$t configure -frametype double -minwidth [expr {[string length $title]+2}]
}
string {
set topiclens [lmap t $topics {string length $t}]
set widest_topic [tcl::mathfunc::max {*}$topiclens]
set about "$pkgname\n"
append about [string repeat - $widest_topic] \n
}
dict {
set about [dict create]
}
} }
foreach topic $topics { foreach topic $topics {
if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} {
@ -11584,14 +11924,20 @@ tcl::namespace::eval punk::args::package {
} else { } else {
set topic_contents "<unavailable>" set topic_contents "<unavailable>"
} }
if {!$is_table} { switch -- $opt_return {
set content_lines [split $topic_contents \n] table - tableobject {
append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n $t add_row [list $topic $topic_contents]
foreach ln [lrange $content_lines 1 end] { }
append about [format %-${widest_topic}s ""] " " $ln \n string {
set content_lines [split $topic_contents \n]
append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n
foreach ln [lrange $content_lines 1 end] {
append about [format %-${widest_topic}s ""] " " $ln \n
}
}
dict {
dict set about $topic $topic_contents
} }
} else {
$t add_row [list $topic $topic_contents]
} }
} }
@ -11662,6 +12008,121 @@ tcl::namespace::eval punk::args::system {
} }
# == === === === === === === === === === === === === === ===
# Sample 'about' function with punk::args documentation
# == === === === === === === === === === === === === === ===
tcl::namespace::eval punk::args {
namespace eval argdoc {
#namespace for custom argument documentation
namespace import ::punk::args::helpers::*
proc package_name {} {
return punk::args
}
proc about_topics {} {
#info commands results are returned in an arbitrary order (like array keys)
set topic_funs [info commands [namespace current]::get_topic_*]
set about_topics [list]
foreach f $topic_funs {
set tail [namespace tail $f]
lappend about_topics [string range $tail [string length get_topic_] end]
}
#Adjust this function or 'default_topics' if a different order is required
return [lsort $about_topics]
}
proc default_topics {} {return [list Description *]}
# -------------------------------------------------------------
# get_topic_ functions add more to auto-include in about topics
# -------------------------------------------------------------
proc get_topic_Description {} {
punk::args::lib::tstr -indent " " [string trim {
package punk::args
Argument parsing library for Tcl.
Can be used purely for documentation of arguments and options, or also for actual argument parsing in procs.
supports longopts-style options, subcommands, and generation of help text.
"mash options" aka "short option bundling" or "flag/option stacking"
punk::args supports mash options for single letter flags that don't take arguments, e.g -a -b -c -> -abc or -bac etc
The last option in a mash can take an argument, e.g -x -v -f <filename> -> -xvf <filename>
Note the number of permutations of options with mashing can get large quickly.
(e.g 10 flags would have 10! = 3,628,800 permutations if all could be mashed together)
This has implications if we also support unique abbreviations of options as every permutation of the mashing
would need to be checked for conflicts with other options and their abbreviations.
The chosen solution is to determine the longest possible mashes for a given set of options, and then require
any abbreviations of other -options to be longer than the longest mash, so that there is no ambiguity between
an abbreviation and a mash.
E.g if we have -mash true and the options -a -b -c -d -backwards -cabinet -call, then the longest mash/bundle is 4 chars
(-abcd -bacd etc), so using the longest mash/bundle length of 4, we require that any abbreviation of other options must be at
least 5 chars long.
In this case -backwards could be abbreviated to -backw or -backwa etc, but not to -ba, -bac or -back.
As an exact match; -call would be accepted.
Whilst in this specific case -back is theoretically unambiguous - we still stick to the rule of requiring abbreviations to be
longer than the longest mash, to keep the rules simple and consistent; and so easier to process and to predict and reason about.
Although the combinations of -a -b -c -d are manageable in this case, if we had more single-letter options we would
not want to use a huge number of combinations of mashes to calculate the allowable prefix matches.
we calculate prefixes based on the flag names as usual, but extend the required prefixes of options such as -cabinet to be longer
(-cab extended to -cabin, -cal extended to -call).
} \n]
}
proc get_topic_License {} {
return " BSD 3-Clause"
}
proc get_topic_Version {} {
return " $::punk::args::version"
}
proc get_topic_Contributors {} {
set authors {{Julian Noble <julian@precisium.com.au>}}
set contributors ""
foreach a $authors {
append contributors $a \n
}
if {[string index $contributors end] eq "\n"} {
set contributors [string range $contributors 0 end-1]
}
return [punk::lib::tstr -indent " " $contributors]
}
proc get_topic_notes {} {
punk::args::lib::tstr -indent " " -return string {
see output of:
punk::args::usage ::punk::args::parse
As a convenience in a shell with the various punk packages loaded, you can also do:
i punk::args::parse
Here i is an alias for punk::ns::cmdhelp which allows lookup of unqualified command names
based on the current context.
}
}
# -------------------------------------------------------------
}
# we re-use the argument definition from punk::args::standard_about and override some items
set overrides [dict create]
dict set overrides @id -id "::punk::args::about"
dict set overrides @cmd -name "punk::args::about"
dict set overrides @cmd -help [string trim [punk::args::lib::tstr {
About punk::args
}] \n]
dict set overrides topic -choices [list {*}[punk::args::argdoc::about_topics] *]
dict set overrides topic -choicerestricted 1
dict set overrides topic -default [punk::args::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *]
lappend PUNKARGS [list $newdef]
proc about {args} {
package require punk::args
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on
set argd [punk::args::parse $args withid ::punk::args::about]
lassign [dict values $argd] _leaders opts values _received
punk::args::package::standard_about -package_about_namespace ::punk::args::argdoc {*}$opts {*}[dict get $values topic]
}
}
# end of sample 'about' function
# == === === === === === === === === === === === === === ===
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready ## Ready

2
src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm

@ -3315,7 +3315,7 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
Each element except ${$B}type${$N} is a decimal string with the value of the corresponding field from the Each element except ${$B}type${$N} is a decimal string with the value of the corresponding field from the
stat return structure; see the manual entry for stat for details on the meanings of the values. stat return structure; see the manual entry for stat for details on the meanings of the values.
The type element gives the type of the file in the same form returned by the command ${$B}file type${$N}." The type element gives the type of the file in the same form returned by the command ${$B}file type${$N}."
@values -min 1 -max 1 @values -min 1 -max 2
name -optional 0 -type string name -optional 0 -type string
varName -type string -optional 1 varName -type string -optional 1
} "@doc -name Manpage: -url [manpage_tcl file]"] } "@doc -name Manpage: -url [manpage_tcl file]"]

19
src/bootsupport/modules/punk/nav/ns-0.1.0.tm

@ -54,12 +54,19 @@ tcl::namespace::eval punk::nav::ns {
n// p* - list namespaces below current and commands in current matching p* n// p* - list namespaces below current and commands in current matching p*
} }
@values -min 1 -max -1 -type string @values -min 1 -max -1 -type string
v -type string -choices {/ //} -help\ v -type string\
" -choices {/ // ///}\
/ - list namespaces only -choicelabels {
// - list namespaces and commands /\
/// - list namespaces, commands and commands resolvable via 'namespace path' "list namespaces only"
" //\
"list namespaces and commands"
///\
"list namespaces, commands and commands
resolvable via 'namespace path'"
}\
-help\
"The form of navigation/listing to perform."
nsglob -type string -optional true -multiple true -help\ nsglob -type string -optional true -multiple true -help\
"A glob pattern supporting placeholders * and ?, to filter results. "A glob pattern supporting placeholders * and ?, to filter results.
If multiple patterns are supplied, then a listing for each pattern is returned. If multiple patterns are supplied, then a listing for each pattern is returned.

148
src/bootsupport/modules/punk/repo-0.1.1.tm

@ -85,25 +85,40 @@ namespace eval punk::repo {
set allcmds [runout -n fossil help -a] set allcmds [runout -n fossil help -a]
set mainhelp [runout -n fossil help] set mainhelp [runout -n fossil help]
set maincommands [list] set maincommands [list]
#only start parsing for TOPICS after a line such as "Other comman values for TOPIC:"
set parsing_topics 0
foreach ln [split $mainhelp \n] { foreach ln [split $mainhelp \n] {
set ln [string trim $ln] set ln [string trim $ln]
if {$ln eq "" || [regexp {^[A-Z]+} $ln]} { if {$ln eq ""} {
continue continue
} }
lappend maincommands {*}$ln if {[string match "*values for TOPIC*" $ln]} {
set parsing_topics 1
continue
}
if {$parsing_topics} {
#lines starting with uppercase are topic headers - we want to ignore these and any blank lines
if {[regexp {^[A-Z]+} $ln]} {
continue
}
lappend maincommands {*}$ln
}
} }
#fossil output was ordered in columns, but we loaded list in row-wise, messing up the order #fossil output was ordered in columns, but we loaded list in row-wise, messing up the order
set maincommands [lsort $maincommands] set maincommands [lsort $maincommands]
set allcmds [lsort $allcmds] set allcmds [lsort $allcmds]
set othercmds [punk::lib::ldiff $allcmds $maincommands] set othercmds [punk::lib::ldiff $allcmds $maincommands]
set fossil_setting_names [lsort [runout -n fossil help -s]]
set result "@leaders -min 0\n" set result "@leaders -min 0\n"
append result [tstr -return string { append result [tstr -return string {
subcommand -type string -choicecolumns 8 -choicegroups { subcommand -type string -choicecolumns 8 -choicegroups {
"frequently used commands" {${$maincommands}} "frequently used commands" {${$maincommands}}
"" {${$othercmds}} "" {${$othercmds}}
} -choiceinfo {add {{doctype punkargs}} diff {{doctype punkargs}}} } -choiceprefixreservelist {${$fossil_setting_names}} -choiceinfo {add {{doctype punkargs}} diff {{doctype punkargs}}}
}] }]
#-choiceinfo { #-choiceinfo {
# add {{doctype punkargs}} # add {{doctype punkargs}}
@ -132,20 +147,127 @@ namespace eval punk::repo {
#experiment #experiment
lappend PUNKARGS [list {
@dynamic proc get_fossil_subcommand_usage {subcmd} {
@id -id "::punk::repo::fossil_proxy diff" set result ""
@cmd -name "fossil diff" -help "fossil diff" append result "@leaders -min 0 -max 0\n"
@formdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}} append result "@opts\n"
} ""] #The -o output sometimes includes portions of the general help text that happens to describe options.
#e.g fossil help diff -o includes
# "--webpage -y HTML output in the side-by-side format"
#as well as:
#" --webpage Format output as a stand-alone HTML webpage"
# we also get duplicates for --tk --by -b -y
#this suggests -o just does a basic parsing of the usage text and pulls out anything that looks like an option.
#other commands such as: fossil help fdiff -o
# return no options - but the help text states that fdiff accepts the same options as diff.
set basic_opt_lines [split [runout -n fossil help $subcmd -o] \n]
set help_lines [split [runout -n fossil help $subcmd] \n]
#first set of lines are for Usage:
#e.g
# % fossil help diff
# Usage: fossil diff|gdiff ?OPTIONS? FILE1 ?FILE2 ...?
# % fossil help ls
# Usage: fossil ls ?OPTIONS? ?PATHS ...?
#When there are multiple forms of usage we may get some "or:" lines.
#e.g
# % fossil help commit
# Usage: fossil commit ?OPTIONS? ?FILE...?
# or: fossil ci ?OPTIONS? ?FILE...?
# % fossil help mv
# Usage: fossil mv|rename ?OPTIONS? OLDNAME NEWNAME
# or: fossil mv|rename ?OPTIONS? OLDNAME... DIR
#(at least some "unsupported" test- commands don't provide a Usage line at all - e.g fossil help test-http)
foreach ln $basic_opt_lines {
set ln [string trim $ln]
if {$ln eq ""} {
continue
}
#the truncated description lines aren't useful here - but are always separated from the option info by more than one space.
set colbreak [string first " " $ln] ;#first occurrence of 2 spaces in a row - which is the separator between option info and description in fossil help output
set optinfo [string range $ln 0 $colbreak-1]
#this isn't the full help info for the option - but it's what we have available in the output of 'fossil help subcmd -o' - which is more concise and easier to parse than the full help for each option.
#todo - call fossil help <subcmd> and retrieve full help for each option.
set temphelp [string range $ln $colbreak end]
set opthelp [string trim $temphelp]
#we expect either one or two parts.
lassign $optinfo namepart typepart
#e.g --case-sensitive BOOL
#e.g -v|--verbose
#e.g -ci|--checkin VERSION (convert to -ci|--checkin=|--checkin -type VERSION)
if {$typepart ne ""} {
set optnames [split $namepart "|"]
#rebuild optnames as punkoptiondef string retaining dashes and pipes but adding in additional forms for longopts - e.g -ci|--checkin becomes -ci|--checkin=|--checkin
set punknames [list]
foreach n $optnames {
if {[string match --* $n]} {
#set n [list $n [string range $n 2 end]= [string range $n 2 end]]
lappend punknames $n ${n}=
} elseif {[string match -* $n]} {
lappend punknames $n
} else {
error "Unexpected option format: $n"
}
}
set typepart "-type $typepart"
} else {
#use as is if the flag doesn't have an argument - e.g -v|--verbose
set punknames $namepart
set typepart "-type none"
}
set punkoptiondef [join $punknames "|"]
append result [tstr -return string {
${$punkoptiondef} ${$typepart} -help {${$opthelp}}
}]
}
append result [tstr -return string {
@values -min 1 -max -1
file -type string -multiple 1 -help "file or directory to add to fossil"
}]
return $result
}
lappend PUNKARGS [list { lappend PUNKARGS [list {
#todo - remove this comment - testing dynamic directive #todo - remove this comment - testing dynamic directive
@dynamic @dynamic
@id -id "::punk::repo::fossil_proxy add" @id -id "::punk::repo::fossil_proxy add"
@cmd -name "fossil add" -help "fossil add @cmd -name "fossil add"\
" -summary\
""\
-help "fossil add"
@form -form "parsed"
${[punk::repo::get_fossil_subcommand_usage add]}
@form -form "raw" -synopsis "exec fossil add ?OPTIONS? FILE1 ?FILE2 ...?"
@formdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} @formdisplay -header "fossil help add" -body {${[runout -n fossil help add]}}
} ""] } ""]
lappend PUNKARGS [list {
@id -id "::punk::repo::fossil_proxy diff"
@cmd -name "fossil diff"\
-summary\
""\
-help\
"fossil diff"
@form -form "parsed"
${[punk::repo::get_fossil_subcommand_usage diff]}
@form -form "raw" -synopsis "exec fossil diff ?OPTIONS? FILE1 ?FILE2 ...?"
@formdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}}
} ""]
#TODO #TODO
#lappend PUNKARGS [list { #lappend PUNKARGS [list {
# @dynamic # @dynamic

537
src/modules/punk/args-999999.0a1.0.tm

@ -665,6 +665,8 @@ tcl::namespace::eval punk::args {
%B%@opts%N% ?opt val...? %B%@opts%N% ?opt val...?
directive-options: -any|-arbitrary <bool> directive-options: -any|-arbitrary <bool>
(also accepts options as defaults for subsequent flag definitions) (also accepts options as defaults for subsequent flag definitions)
e.g -mash 1 - default to single letter flags to be mashable/combinable
(-abc instead of -a -b -c)
%B%@values%N% ?opt val...? %B%@values%N% ?opt val...?
(used for trailing args that come after switches/opts) (used for trailing args that come after switches/opts)
directive-options: -min <int> -max <int> -unnamed <bool> directive-options: -min <int> -max <int> -unnamed <bool>
@ -813,6 +815,22 @@ tcl::namespace::eval punk::args {
Further unambiguous arrangements of optional args may be Further unambiguous arrangements of optional args may be
made in future - but are currently considered 'unsupported' made in future - but are currently considered 'unsupported'
-default <value> -default <value>
-mash <bool> (for flags/switches only)
Option clustering, flag stacking, option mashing
- all refer to the same thing:
Whether single letter flags can be mashed together.
E.g -abc instead of -a -b -c
This defaults to false, but can be set to true for all
single-letter flags by setting -mash true on the @opts directive.
It is an error to explicitly set -mash true on a flag that doesn't
have a single letter as part it's name.
(e.g it is ok on -f or even -f|--flag)
When such flags are combined, only the last one can take a value.
E.g with -mash true and flags -a -b and -c that take no values,
and -f that takes a value:
-abc is valid and equivalent to -a -b -c
-abcf <value> is valid and equivalent to -a -b -c -f <value>
but -afc <value> is not valid
-multiple <bool> (for leaders & values defines whether -multiple <bool> (for leaders & values defines whether
subsequent received values are stored against the same subsequent received values are stored against the same
argument name - only applies to final leader OR final value) argument name - only applies to final leader OR final value)
@ -1008,6 +1026,7 @@ tcl::namespace::eval punk::args {
-validate_ansistripped 0\ -validate_ansistripped 0\
-strip_ansi 0\ -strip_ansi 0\
-nocase 0\ -nocase 0\
-mash 0\
-choiceprefix 1\ -choiceprefix 1\
-choicerestricted 1\ -choicerestricted 1\
-choicemultiple {1 1}\ -choicemultiple {1 1}\
@ -1065,6 +1084,8 @@ tcl::namespace::eval punk::args {
OPT_MIN ""\ OPT_MIN ""\
OPT_MAX ""\ OPT_MAX ""\
OPT_SOLOS {}\ OPT_SOLOS {}\
OPT_MASHES {}\
OPT_ALL_MASH_LETTERS {}\
OPTSPEC_DEFAULTS $optdirective_defaults\ OPTSPEC_DEFAULTS $optdirective_defaults\
OPT_CHECKS_DEFAULTS {}\ OPT_CHECKS_DEFAULTS {}\
OPT_GROUPS {}\ OPT_GROUPS {}\
@ -1548,15 +1569,18 @@ tcl::namespace::eval punk::args {
"" - # {continue} "" - # {continue}
} }
incr record_number incr record_number
if {[catch {lassign $trimrec firstword}]} { #after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict
if {[catch {set record_values [lassign $trimrec firstword]}]} {
puts stdout "----------------------------------------------" puts stdout "----------------------------------------------"
puts stderr "rec: $rec" puts stderr "rec: $rec"
set ::testrecord $rec set ::testrecord $rec
puts stdout "----------------------------------------------" puts stdout "----------------------------------------------"
puts "records: $records" puts "records: $records"
puts stdout "==============================================" puts stdout "=============================================="
error "punk::args::resolve - bad optionspecs line - unable to parse first word of record '$trimrec' id:$DEF_definition_id"
} }
set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict #set record_values [lassign $trimrec firstword]
if {[llength $record_values] % 2 != 0} { if {[llength $record_values] % 2 != 0} {
#todo - avoid raising an error - store invalid defs keyed on id #todo - avoid raising an error - store invalid defs keyed on id
error "punk::args::resolve - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" error "punk::args::resolve - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id"
@ -1808,6 +1832,14 @@ tcl::namespace::eval punk::args {
#set opt_any $v #set opt_any $v
tcl::dict::set F $fid OPT_ANY $v tcl::dict::set F $fid OPT_ANY $v
} }
-mash {
#default for single letter options that can be mashed together - e.g -a -b can be supplied as -ab if -mash is 1
#check is bool
if {![string is boolean -strict $v]} {
error "punk::args::resolve - Option '$k' has value '$v'of wrong type in @opts line. Must be boolean @id:$DEF_definition_id"
}
tcl::dict::set tmp_optspec_defaults $k $v
}
-min { -min {
dict set F $fid OPT_MIN $v dict set F $fid OPT_MIN $v
} }
@ -1918,7 +1950,7 @@ tcl::namespace::eval punk::args {
} }
default { default {
set known { -parsekey -group -grouphelp\ set known { -parsekey -group -grouphelp\
-any -anyopts -arbitrary -form -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo\ -any -anyopts -mash -arbitrary -form -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo\
-type -range -typeranges -default -defaultdisplaytype -typedefaults -type -range -typeranges -default -defaultdisplaytype -typedefaults
-choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted -nocase\ -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted -nocase\
-unindentedfields\ -unindentedfields\
@ -2402,6 +2434,8 @@ tcl::namespace::eval punk::args {
foreach fid $record_form_ids { foreach fid $record_form_ids {
if {$is_opt} { if {$is_opt} {
#OPTSPEC_DEFAULTS are the base defaults for options - these can be overridden by @opts lines
#we may still need to test some of these defaults for validity, e.g -mash true can only apply if the argname has at least one single-character alias (e.g -x or -x|--xxx)
set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS] set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS]
} else { } else {
if {[dict get $F $fid argspace] eq "values"} { if {[dict get $F $fid argspace] eq "values"} {
@ -2518,6 +2552,25 @@ tcl::namespace::eval punk::args {
-parsekey - -group { -parsekey - -group {
tcl::dict::set spec_merged -typesynopsis $specval tcl::dict::set spec_merged -typesynopsis $specval
} }
-mash {
#allow when any alt in argname is a single letter flag such s -a or -Z
#single letter flags do not have to be -type none to allow -mash to be set true.
#a mash can be supplied where the last flag in the mash is a value-taking flag.
if {$specval} {
set has_single_letter_flag 0
foreach alias $optaliases {
if {[string length $alias] == 2 && [string match -* $alias]} {
set has_single_letter_flag 1
break
}
}
if {!$has_single_letter_flag} {
error "punk::args::resolve - invalid use of -mash for argument '$argname'. -mash can only be true if at least one alias in the argname is a single-letter flag (e.g -a or -Z) @id:$DEF_definition_id"
#todo - we also have to set -mash false when processing defaults from @opts if the argname doesn't contain any single-letter flags
}
}
tcl::dict::set spec_merged -mash $specval
}
-unindentedfields - -unindentedfields -
-solo - -solo -
-choices - -choicegroups - -choicemultiple - -choicecolumns - -choices - -choicegroups - -choicemultiple - -choicecolumns -
@ -2661,6 +2714,30 @@ tcl::namespace::eval punk::args {
if {[tcl::dict::get $spec_merged -type] eq "none"} { if {[tcl::dict::get $spec_merged -type] eq "none"} {
dict set F $fid OPT_SOLOS [list {*}[dict get $F $fid OPT_SOLOS] $argname] dict set F $fid OPT_SOLOS [list {*}[dict get $F $fid OPT_SOLOS] $argname]
} }
if {[tcl::dict::get $spec_merged -mash]} {
#The value for -mash might be true only due to a default from @opts - in which case we need to check the argname for validity of -mash as described above and if not valid, set -mash false in the ARG_INFO for this argname
if {$argname eq "--"} {
#force -mash false - in case no -mash was specified on the flag itself and @opts -mash is true
tcl::dict::set spec_merged -mash false
} else {
set has_single_letter_flag 0
foreach alias $optaliases {
if {[string length $alias] == 2 && [string match -* $alias]} {
set has_single_letter_flag 1
break
}
}
if {!$has_single_letter_flag} {
#force -mash false in ARG_INFO for this argname - in case no -mash was specified and @opts -mash is true by default but argname doesn't contain any single-letter flags
tcl::dict::set spec_merged -mash false
}
}
#re-test state of -mash after any adjustments based on argname validity and defaults
if {[tcl::dict::get $spec_merged -mash]} {
#we add the whole argname with all aliases to the OPT_MASHES list - this is used during parsing to check if any of the aliases for a given flag are mashable
dict set F $fid OPT_MASHES [list {*}[dict get $F $fid OPT_MASHES] $argname]
}
}
} else { } else {
tcl::dict::set F $fid ARG_CHECKS $argname\ tcl::dict::set F $fid ARG_CHECKS $argname\
[tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi -choicecolumns -group -typesynopsis -help -ARGTYPE] ;#leave things like -range -minsize [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi -choicecolumns -group -typesynopsis -help -ARGTYPE] ;#leave things like -range -minsize
@ -2716,6 +2793,21 @@ tcl::namespace::eval punk::args {
#now cycle through ALL forms not just form_ids_active (record_form_ids) #now cycle through ALL forms not just form_ids_active (record_form_ids)
dict for {fid formdata} $F { dict for {fid formdata} $F {
set mashargs [dict get $F $fid OPT_MASHES]
if {[llength $mashargs]} {
#precalculate OPT_ALL_MASH_LETTERS
set all_mash_letters [list]
foreach fullopt $mashargs {
foreach flagpart [split $fullopt |] {
if {[string length $flagpart] == 2 && [string match -* $flagpart]} {
lappend all_mash_letters [string index $flagpart 1]
}
}
}
dict set F $fid OPT_ALL_MASH_LETTERS $all_mash_letters
}
if {[tcl::dict::get $F $fid OPT_MAX] eq ""} { if {[tcl::dict::get $F $fid OPT_MAX] eq ""} {
if {[llength [tcl::dict::get $F $fid OPT_NAMES]] == 0 && ![tcl::dict::get $F $fid OPT_ANY]} { if {[llength [tcl::dict::get $F $fid OPT_NAMES]] == 0 && ![tcl::dict::get $F $fid OPT_ANY]} {
tcl::dict::set F $fid OPT_MAX 0 ;#aid in parsing to avoid scanning for opts unnecessarily tcl::dict::set F $fid OPT_MAX 0 ;#aid in parsing to avoid scanning for opts unnecessarily
@ -3292,8 +3384,8 @@ tcl::namespace::eval punk::args {
return true return true
} }
foreach d $rawdef { foreach d $rawdef {
if {[regexp {\s*(\S+)} $d _match firstword]} { if {[regexp {\s*(\S+)} $d _match first_rawdef_word]} {
if {$firstword eq "@dynamic"} { if {$first_rawdef_word eq "@dynamic"} {
return true return true
} }
} }
@ -3513,7 +3605,7 @@ tcl::namespace::eval punk::args {
} }
# -- --- --- --- --- --- # -- --- --- --- --- ---
set unscanned [punklib_ldiff $registered $scanned_packages] set unscanned [punk::args::system::punklib_ldiff $registered $scanned_packages]
if {[llength $unscanned]} { if {[llength $unscanned]} {
foreach pkgns $unscanned { foreach pkgns $unscanned {
set idcount 0 set idcount 0
@ -3562,7 +3654,7 @@ tcl::namespace::eval punk::args {
if {"*" in $nslist} { if {"*" in $nslist} {
set needed [punklib_ldiff $registered $loaded_packages] set needed [punk::args::system::punklib_ldiff $registered $loaded_packages]
} else { } else {
set needed [list] set needed [list]
foreach pkgns $nslist { foreach pkgns $nslist {
@ -4311,6 +4403,33 @@ tcl::namespace::eval punk::args {
set trie [punk::trie::trieclass new {*}$all_opts --] set trie [punk::trie::trieclass new {*}$all_opts --]
set idents [dict get [$trie shortest_idents ""] scanned] set idents [dict get [$trie shortest_idents ""] scanned]
if {[llength [dict get $form_dict OPT_MASHES]]} {
set all_mash_letters [dict get $form_dict OPT_ALL_MASH_LETTERS]
#now extend idents to be at least as long as the number of mash/bundle flags that exist.
#(when the flag itself is longer than number of mash flags
# - e.g for flags -x -v -c -f -collection, the ident for -collection would be -co normally
# but if we have 4 mash flags, we want it to be -colle to satisfy the requirement that it is longer then the number of mash flags
# unless it is an exact match.)
#
#e.g if all the single letter flags are configured with -mash true:
#our prefix calculation might give us the following idents:
# idents: -cabinet -ca -a -a -b -b -c -c -- --
#we need only to extend -cabinet to -cabi to satisfy the requirement that it is longer than the number of mash flags (3 in this example because -- is never a mash flag)
dict for {fullname ident} $idents {
set mashcount [llength $all_mash_letters]
#assert: if we are here - mashcount > 0
if {[string length $ident] < [string length $fullname] && [string length $ident] <= $mashcount} {
dict set idents $fullname [string range $fullname 0 $mashcount+1]
}
}
#note it's still possible for the user to define a flag with a name shorter than the number of mash flags
# and it could even overlap with a specific combination of mash letters - e.g -a -b -c -d and a flag named -bac
# - in this case a provided value of -bac would still match the flag -bac rather than being treated as a mash of -b -a -c
#because the exact match will take priority over the prefix match.
#Whilst this configuration is accepted - it's not recommended.
}
#todo - check opt_prefixdeny #todo - check opt_prefixdeny
$trie destroy $trie destroy
@ -7906,6 +8025,8 @@ tcl::namespace::eval punk::args {
#set OPT_MIN [dict get $formdict OPT_MIN] #set OPT_MIN [dict get $formdict OPT_MIN]
set OPT_MAX [dict get $formdict OPT_MAX] set OPT_MAX [dict get $formdict OPT_MAX]
#set OPT_SOLOS [dict get $formdict OPT_SOLOS] #set OPT_SOLOS [dict get $formdict OPT_SOLOS]
set OPT_MASHES [dict get $formdict OPT_MASHES]
set OPT_ALL_MASH_LETTERS [dict get $formdict OPT_ALL_MASH_LETTERS]
set OPTSPEC_DEFAULTS [dict get $formdict OPTSPEC_DEFAULTS] set OPTSPEC_DEFAULTS [dict get $formdict OPTSPEC_DEFAULTS]
set OPT_CHECKS_DEFAULTS [dict get $formdict OPT_CHECKS_DEFAULTS] set OPT_CHECKS_DEFAULTS [dict get $formdict OPT_CHECKS_DEFAULTS]
#set OPT_GROUPS [dict get $formdict OPT_GROUPS] #set OPT_GROUPS [dict get $formdict OPT_GROUPS]
@ -7956,8 +8077,11 @@ tcl::namespace::eval punk::args {
} }
} }
} }
#note all_opts will necessarily not include mashed flags (e.g -abc) when only -a -b -c are defined - but we will detect and break those down in the main loop below
set all_opts [dict keys $lookup_optset] set all_opts [dict keys $lookup_optset]
set ridx 0 set ridx 0
set rawargs_copy $rawargs set rawargs_copy $rawargs
set remaining_rawargs $rawargs set remaining_rawargs $rawargs
@ -8374,15 +8498,225 @@ tcl::namespace::eval punk::args {
#flagsupplied when --longopt=x is --longopt (may still be a prefix) #flagsupplied when --longopt=x is --longopt (may still be a prefix)
#get full flagname from possible prefix $flagsupplied #get full flagname from possible prefix $flagsupplied
set flagname [tcl::prefix match -error "" [list {*}$all_opts --] $flagsupplied] set flagname [tcl::prefix match -error "" [list {*}$all_opts --] $flagsupplied]
if {$flagname eq "--"} { #The prefix matching above doesn't consider that mashed flags can make shorter prefixes an invalid match for the whole flag.
set optionset "" #if the length of our matched flagname is less than the length of $OPT_ALL_MASH_LETTERS, then we may have a mash of other flags,
} else { #not a valid match for some longer flag that just happens to share the same prefix as the start of the mash.
if {[dict exists $lookup_optset $flagname]} { #we have defined valid prefix matches in the presence of mashed flags to be only those that are longer than any possible mash of flags
set optionset [dict get $lookup_optset $flagname]
} else { #(review - for small numbers of mashed flags we could be more precise, but the combinatoric explosion of longer mash lengths makes it
#simpler to just say any match that is shorter than the length of the longest possible mash is invalid
# we may need consider what common utilities do in practice regarding allowing prefixes in the presence of mashed flags
#- but it seems likely that they would either not allow prefixes at all, or only allow prefixes that are longer than any possible mash of flags)
#So if we have a match that isn't exact and is shorter than the length of the longest possible mash, we need to check if it's actually a mash of valid flags rather than a valid prefix match for a longer flag.
if {$flagname ne $flagsupplied && [llength $OPT_MASHES] && (([string length $flagsupplied] -1) <= [llength $OPT_ALL_MASH_LETTERS])} {
#invalidate the match
set flagname ""
}
switch -- $flagname {
-- {
set optionset "" set optionset ""
} }
"" {
#no match for flagname - could be a mashed flag e.g -abc where only -a -b -c are defined
if {![llength $OPT_MASHES]} {
#no mashed flags defined - so this probably isn't a flag - could be a value
set optionset ""
} else {
#check if every letter after the first matches a defined opt - if so treat as mashed flags
set mashflags [string range $flagsupplied 1 end]
set mashletters [split $mashflags ""]
set all_mashable true
foreach mf $mashletters {
if {$mf ni $OPT_ALL_MASH_LETTERS} {
set all_mashable false
break
}
}
#todo - move block below up here.
if {!$all_mashable} {
puts stderr "Debug: flagsupplied '$flagsupplied' not a valid flagname and not a valid mash of flags - treating as value"
#- probably isn't a flag at all - could be a value
#treat as value
set optionset ""
} else {
#puts stderr "Debug: flagsupplied '$flagsupplied' not a valid flagname but is a valid mash of flags - treating as mash of flags"
#treat as mashed flags - we will break down into individual flags and process each one in turn
set optionset $flagsupplied
#the -mash option means we may have to process multiple flags as received for one arg that looks like a flag
#we can still use the lookup_optset dict to get the optionset for each individual flag - as the keys of lookup_optset are all the individual flags (not mashed together)
#we need to update:
# vals_remaining_possible after processing all matchletters (by -1 or -2 depending on whether the mash includes a flag with an attached value (trailing=<val>) or accepts a value.)
# multisreceived
# soloreceived (if any of the flags in the mash are solo)
# flagsreceived (add the mash as received - but also add each individual flag in the mash as received for the purposes of checking for multiple and solo)
# opts (for each flag in the mash)
set posn 0
set consume_value 0 ;#if last mash flag accepts a value, we will consume the next arg as its value
foreach mf $mashletters {
set matchopt [dict get $lookup_optset -$mf]
if {$matchopt eq ""} {
#this should not happen as we have already checked all letters are mashable - but check just in case
puts stderr "Debug: mash letter '-$mf' not in lookup_optset - this should not happen"
} else {
#process each mashed flag as if it were received separately
#- we can reuse the same flagval for each as they won't be expected to have values (as they are single letter flags)
#we will still need to check for multiple and defaults for each individual flag
#we can also still use the same argstate entries for each individual flag as the optionset will be the same for each of the mashed flags (as they will all be defined in the same optionset e.g -a|-b|-c)
set mashflagname -$mf
set mashflagoptionset [dict get $lookup_optset $mashflagname]
set raw_optionset_members [split $mashflagoptionset |]
#set mashflagapiopt [dict get $argstate $mashflagoptionset -parsekey]
#if {$mashflagapiopt eq ""} {
# set mashflagapiopt [string trimright [lindex [split $mashflagoptionset |] end] =]
#}
set flagname -$mf
if {[tcl::dict::get $argstate $mashflagoptionset -parsekey] ne ""} {
set api_opt [dict get $argstate $mashflagoptionset -parsekey]
} else {
set api_opt [string trimright [lindex $raw_optionset_members end] =]
}
if {$api_opt eq $flagname} {
set flag_ident $api_opt
set flag_ident_is_parsekey 0
} else {
#initially key our opts on a long form allowing us to know which specific flag was used
#(for when multiple map to same parsekey e.g lsearch)
#e.g -increasing|-SORTOPTION
set flag_ident $flagname|$api_opt
set flag_ident_is_parsekey 1
}
set optionset_type [tcl::dict::get $argstate $mashflagoptionset -type]
#only the last flag in a mash can be allowed to have a value, and the other flags must be of type none.
#flags are by default optional.
if {$optionset_type ne "none"} {
#A flag with a value - only allowed for the last flag in a mash
if {$posn != [expr {[llength $mashletters] - 1}]} {
#not the last flag in the mash - can't have a value
set errmsg "bad options for %caller%. Flag \"$mashflagname\" in mash \"$flagsupplied\" cannot have a value as only the last flag in a mash can have a value. The flag \"$mashflagname\" must be of type none. (1)"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $all_opts] -badarg $a -argspecs $argspecs]] $errmsg
} else {
set consume_value 1
# ------------
#check if it was actually a value that looked like a flag
if {$i == $maxidx} {
#if no optvalue following - assume it's a value
#(caller should probably have used -- before it)
#review
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
break
}
#flagval comes from next remaining rawarg
set flagval [lindex $remaining_rawargs $i+1]
if {[tcl::dict::get $argstate $mashflagoptionset -multiple]} {
#don't lappend to default - we need to replace if there is a default
if {$api_opt ni $flagsreceived} {
tcl::dict::set opts $flag_ident [list $flagval]
} else {
tcl::dict::lappend opts $flag_ident $flagval
}
if {$api_opt ni $multisreceived} {
lappend multisreceived $api_opt
}
} else {
#tcl::dict::set opts $flag_ident $flagval
if {$flag_ident_is_parsekey} {
#necessary shimmer ?
lappend opts $flag_ident $flagval
} else {
tcl::dict::set opts $flag_ident $flagval
}
}
#incr i to skip flagval
#incr vals_remaining_possible -2
#if {[incr i] > $maxidx} {
# set msg "Bad options for %caller%. No value supplied for last option $mashflagoptionset at index [expr {$i-1}] which is not marked with -type none"
# return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $mashflagoptionset index [expr {$i-1}]] -badarg $mashflagoptionset -argspecs $argspecs]] $msg
#}
# ------------
}
} else {
#flag with no value - check for -typedefaults for the flag
#none / solo
if {[tcl::dict::exists $argstate $mashflagoptionset -typedefaults]} {
set tdflt [tcl::dict::get $argstate $mashflagoptionset -typedefaults]
} else {
#normal default for a solo is 1 unless overridden by -typedefaults
set tdflt 1
}
if {[tcl::dict::get $argstate $mashflagoptionset -multiple]} {
#puts stderr "Debug: flag '$mashflagname' in mash '$flagsupplied' is a multiple with typedefaults $tdflt -- api_opt: $api_opt flag_ident: $flag_ident flagsreceived: $flagsreceived multisreceived: $multisreceived"
if {$api_opt ni $flagsreceived} {
#override any default - don't lappend to it
tcl::dict::set opts $flag_ident $tdflt
} else {
tcl::dict::lappend opts $flag_ident $tdflt
}
if {$api_opt ni $multisreceived} {
lappend multisreceived $api_opt
}
} else {
#test parse_withdef_parsekey_repeat_ordering {Ensure last flag has precedence}
#tcl::dict::set opts $flag_ident $tdflt
if {$flag_ident_is_parsekey} {
#(shimmer - but required for ordering correctness during override)
puts stderr "Debug: flag '$mashflagname' in mash '$flagsupplied' flag_ident '$flag_ident' is the same as parsekey '$api_opt' tdflt: $tdflt - using lappend to ensure it ends up after any previous flag in the mash that had the same parsekey"
lappend opts $flag_ident $tdflt
puts stderr "opts after lappend: $opts"
} else {
tcl::dict::set opts $flag_ident $tdflt
}
}
#incr vals_remaining_possible -1
lappend solosreceived $api_opt ;#dups ok
}
}
lappend flagsreceived $api_opt
incr posn
}
#update vals_remaining_possible by one or 2 if the last flag took a value.
incr vals_remaining_possible -1
if {$flagval_included || $consume_value} {
incr vals_remaining_possible -1
}
#after processing the mash, we will have updated opts for each individual flag in the mash,
#and updated multisreceived and solo_received as needed based on the optionset entries for each individual flag in the mash
#we possibly need to incr i to skip a received value for the mash if the last flag in the mash had a value.
#or break if we have reached the end of the args after processing the mash
if {$flagval_included || $consume_value} {
#the last flag in the mash had a value - we have already processed it for that flag - so we need to skip it for the next iteration of the loop
incr i
if {$i > $maxidx} {
#we have reached the end of the args after processing the mash and its value - so we can break out of the loop
break
}
} else {
#no value included for the last flag in the mash - so we just continue to the next iteration of the loop to process the next arg
}
continue
}
}
}
default {
if {[dict exists $lookup_optset $flagname]} {
set optionset [dict get $lookup_optset $flagname]
} else {
#we matched a prefix of all_opts - but it's not in the lookup_optset?
#review - this should not happen as we only match prefixes from all_opts which is derived from the keys of lookup_optset
puts stderr "Debug: matched prefix '$flagname' not in lookup_optset - this should not happen"
set optionset ""
}
}
} }
if {$optionset ne ""} { if {$optionset ne ""} {
#matched some option - either in part or in full. #matched some option - either in part or in full.
set raw_optionset_members [split $optionset |] set raw_optionset_members [split $optionset |]
@ -9205,7 +9539,7 @@ tcl::namespace::eval punk::args {
#} #}
#for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us
if {[llength $LEADER_REQUIRED]} { if {[llength $LEADER_REQUIRED]} {
if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { if {[llength [set missing [punk::args::system::punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} {
set msg "Required leader missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" 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 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 #arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs
@ -9213,7 +9547,7 @@ tcl::namespace::eval punk::args {
} }
if {[llength $OPT_REQUIRED]} { if {[llength $OPT_REQUIRED]} {
set api_opt_required [lmap v $OPT_REQUIRED {lindex [split $v |] end}] set api_opt_required [lmap v $OPT_REQUIRED {lindex [split $v |] end}]
if {[llength [set missing [punklib_ldiff $api_opt_required $flagsreceived]]]} { if {[llength [set missing [punk::args::system::punklib_ldiff $api_opt_required $flagsreceived]]]} {
set full_missing [list] set full_missing [list]
foreach m $missing { foreach m $missing {
lappend full_missing [dict get $lookup_optset $m] lappend full_missing [dict get $lookup_optset $m]
@ -9225,7 +9559,7 @@ tcl::namespace::eval punk::args {
} }
} }
if {[llength $VAL_REQUIRED]} { if {[llength $VAL_REQUIRED]} {
if {[llength [set missing [punklib_ldiff $VAL_REQUIRED $valnames_received]]]} { if {[llength [set missing [punk::args::system::punklib_ldiff $VAL_REQUIRED $valnames_received]]]} {
set msg "Required value missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" 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 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 #arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs
@ -10026,8 +10360,8 @@ tcl::namespace::eval punk::args {
set alternates [list];#alternate acceptable types e.g literal(yes)|literal(ok) or indexpression|literal(first) set alternates [list];#alternate acceptable types e.g literal(yes)|literal(ok) or indexpression|literal(first)
set type_alternatives [_split_type_expression $tp] set type_alternatives [_split_type_expression $tp]
foreach tp_alternative $type_alternatives { foreach tp_alternative $type_alternatives {
set firstword [lindex $tp_alternative 0] set tp_alternative_word1 [lindex $tp_alternative 0]
switch -exact -- $firstword { switch -exact -- $tp_alternative_word1 {
literal { literal {
set match [lindex $tp_alternative 1] set match [lindex $tp_alternative 1]
lappend alternates $match lappend alternates $match
@ -11485,7 +11819,7 @@ tcl::namespace::eval punk::args::package {
-return\ -return\
-type string\ -type string\
-default table\ -default table\
-choices {string table tableobject}\ -choices {string table tableobject dict}\
-choicelabels { -choicelabels {
string\ string\
"A basic text layout" "A basic text layout"
@ -11564,19 +11898,25 @@ tcl::namespace::eval punk::args::package {
} }
} }
} }
if {$opt_return ne "string"} {
package require textblock ;#table support
set is_table 1
set title [string cat {[} $pkgname {]} ]
set t [textblock::class::table new -title $title]
$t configure -frametype double -minwidth [expr {[string length $title]+2}]
} else { set is_table 0
set topiclens [lmap t $topics {string length $t}] switch -- $opt_return {
set widest_topic [tcl::mathfunc::max {*}$topiclens] table - tableobject {
set is_table 0 package require textblock ;#table support
set about "$pkgname\n" set is_table 1
append about [string repeat - $widest_topic] \n set title [string cat {[} $pkgname {]} ]
set t [textblock::class::table new -title $title]
$t configure -frametype double -minwidth [expr {[string length $title]+2}]
}
string {
set topiclens [lmap t $topics {string length $t}]
set widest_topic [tcl::mathfunc::max {*}$topiclens]
set about "$pkgname\n"
append about [string repeat - $widest_topic] \n
}
dict {
set about [dict create]
}
} }
foreach topic $topics { foreach topic $topics {
if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} {
@ -11584,14 +11924,20 @@ tcl::namespace::eval punk::args::package {
} else { } else {
set topic_contents "<unavailable>" set topic_contents "<unavailable>"
} }
if {!$is_table} { switch -- $opt_return {
set content_lines [split $topic_contents \n] table - tableobject {
append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n $t add_row [list $topic $topic_contents]
foreach ln [lrange $content_lines 1 end] { }
append about [format %-${widest_topic}s ""] " " $ln \n string {
set content_lines [split $topic_contents \n]
append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n
foreach ln [lrange $content_lines 1 end] {
append about [format %-${widest_topic}s ""] " " $ln \n
}
}
dict {
dict set about $topic $topic_contents
} }
} else {
$t add_row [list $topic $topic_contents]
} }
} }
@ -11662,6 +12008,121 @@ tcl::namespace::eval punk::args::system {
} }
# == === === === === === === === === === === === === === ===
# Sample 'about' function with punk::args documentation
# == === === === === === === === === === === === === === ===
tcl::namespace::eval punk::args {
namespace eval argdoc {
#namespace for custom argument documentation
namespace import ::punk::args::helpers::*
proc package_name {} {
return punk::args
}
proc about_topics {} {
#info commands results are returned in an arbitrary order (like array keys)
set topic_funs [info commands [namespace current]::get_topic_*]
set about_topics [list]
foreach f $topic_funs {
set tail [namespace tail $f]
lappend about_topics [string range $tail [string length get_topic_] end]
}
#Adjust this function or 'default_topics' if a different order is required
return [lsort $about_topics]
}
proc default_topics {} {return [list Description *]}
# -------------------------------------------------------------
# get_topic_ functions add more to auto-include in about topics
# -------------------------------------------------------------
proc get_topic_Description {} {
punk::args::lib::tstr -indent " " [string trim {
package punk::args
Argument parsing library for Tcl.
Can be used purely for documentation of arguments and options, or also for actual argument parsing in procs.
supports longopts-style options, subcommands, and generation of help text.
"mash options" aka "short option bundling" or "flag/option stacking"
punk::args supports mash options for single letter flags that don't take arguments, e.g -a -b -c -> -abc or -bac etc
The last option in a mash can take an argument, e.g -x -v -f <filename> -> -xvf <filename>
Note the number of permutations of options with mashing can get large quickly.
(e.g 10 flags would have 10! = 3,628,800 permutations if all could be mashed together)
This has implications if we also support unique abbreviations of options as every permutation of the mashing
would need to be checked for conflicts with other options and their abbreviations.
The chosen solution is to determine the longest possible mashes for a given set of options, and then require
any abbreviations of other -options to be longer than the longest mash, so that there is no ambiguity between
an abbreviation and a mash.
E.g if we have -mash true and the options -a -b -c -d -backwards -cabinet -call, then the longest mash/bundle is 4 chars
(-abcd -bacd etc), so using the longest mash/bundle length of 4, we require that any abbreviation of other options must be at
least 5 chars long.
In this case -backwards could be abbreviated to -backw or -backwa etc, but not to -ba, -bac or -back.
As an exact match; -call would be accepted.
Whilst in this specific case -back is theoretically unambiguous - we still stick to the rule of requiring abbreviations to be
longer than the longest mash, to keep the rules simple and consistent; and so easier to process and to predict and reason about.
Although the combinations of -a -b -c -d are manageable in this case, if we had more single-letter options we would
not want to use a huge number of combinations of mashes to calculate the allowable prefix matches.
we calculate prefixes based on the flag names as usual, but extend the required prefixes of options such as -cabinet to be longer
(-cab extended to -cabin, -cal extended to -call).
} \n]
}
proc get_topic_License {} {
return " BSD 3-Clause"
}
proc get_topic_Version {} {
return " $::punk::args::version"
}
proc get_topic_Contributors {} {
set authors {{Julian Noble <julian@precisium.com.au>}}
set contributors ""
foreach a $authors {
append contributors $a \n
}
if {[string index $contributors end] eq "\n"} {
set contributors [string range $contributors 0 end-1]
}
return [punk::lib::tstr -indent " " $contributors]
}
proc get_topic_notes {} {
punk::args::lib::tstr -indent " " -return string {
see output of:
punk::args::usage ::punk::args::parse
As a convenience in a shell with the various punk packages loaded, you can also do:
i punk::args::parse
Here i is an alias for punk::ns::cmdhelp which allows lookup of unqualified command names
based on the current context.
}
}
# -------------------------------------------------------------
}
# we re-use the argument definition from punk::args::standard_about and override some items
set overrides [dict create]
dict set overrides @id -id "::punk::args::about"
dict set overrides @cmd -name "punk::args::about"
dict set overrides @cmd -help [string trim [punk::args::lib::tstr {
About punk::args
}] \n]
dict set overrides topic -choices [list {*}[punk::args::argdoc::about_topics] *]
dict set overrides topic -choicerestricted 1
dict set overrides topic -default [punk::args::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *]
lappend PUNKARGS [list $newdef]
proc about {args} {
package require punk::args
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on
set argd [punk::args::parse $args withid ::punk::args::about]
lassign [dict values $argd] _leaders opts values _received
punk::args::package::standard_about -package_about_namespace ::punk::args::argdoc {*}$opts {*}[dict get $values topic]
}
}
# end of sample 'about' function
# == === === === === === === === === === === === === === ===
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready ## Ready

2
src/modules/punk/args/moduledoc/tclcore-999999.0a1.0.tm

@ -3315,7 +3315,7 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
Each element except ${$B}type${$N} is a decimal string with the value of the corresponding field from the Each element except ${$B}type${$N} is a decimal string with the value of the corresponding field from the
stat return structure; see the manual entry for stat for details on the meanings of the values. stat return structure; see the manual entry for stat for details on the meanings of the values.
The type element gives the type of the file in the same form returned by the command ${$B}file type${$N}." The type element gives the type of the file in the same form returned by the command ${$B}file type${$N}."
@values -min 1 -max 1 @values -min 1 -max 2
name -optional 0 -type string name -optional 0 -type string
varName -type string -optional 1 varName -type string -optional 1
} "@doc -name Manpage: -url [manpage_tcl file]"] } "@doc -name Manpage: -url [manpage_tcl file]"]

19
src/modules/punk/nav/ns-999999.0a1.0.tm

@ -54,12 +54,19 @@ tcl::namespace::eval punk::nav::ns {
n// p* - list namespaces below current and commands in current matching p* n// p* - list namespaces below current and commands in current matching p*
} }
@values -min 1 -max -1 -type string @values -min 1 -max -1 -type string
v -type string -choices {/ //} -help\ v -type string\
" -choices {/ // ///}\
/ - list namespaces only -choicelabels {
// - list namespaces and commands /\
/// - list namespaces, commands and commands resolvable via 'namespace path' "list namespaces only"
" //\
"list namespaces and commands"
///\
"list namespaces, commands and commands
resolvable via 'namespace path'"
}\
-help\
"The form of navigation/listing to perform."
nsglob -type string -optional true -multiple true -help\ nsglob -type string -optional true -multiple true -help\
"A glob pattern supporting placeholders * and ?, to filter results. "A glob pattern supporting placeholders * and ?, to filter results.
If multiple patterns are supplied, then a listing for each pattern is returned. If multiple patterns are supplied, then a listing for each pattern is returned.

148
src/modules/punk/repo-999999.0a1.0.tm

@ -85,25 +85,40 @@ namespace eval punk::repo {
set allcmds [runout -n fossil help -a] set allcmds [runout -n fossil help -a]
set mainhelp [runout -n fossil help] set mainhelp [runout -n fossil help]
set maincommands [list] set maincommands [list]
#only start parsing for TOPICS after a line such as "Other comman values for TOPIC:"
set parsing_topics 0
foreach ln [split $mainhelp \n] { foreach ln [split $mainhelp \n] {
set ln [string trim $ln] set ln [string trim $ln]
if {$ln eq "" || [regexp {^[A-Z]+} $ln]} { if {$ln eq ""} {
continue continue
} }
lappend maincommands {*}$ln if {[string match "*values for TOPIC*" $ln]} {
set parsing_topics 1
continue
}
if {$parsing_topics} {
#lines starting with uppercase are topic headers - we want to ignore these and any blank lines
if {[regexp {^[A-Z]+} $ln]} {
continue
}
lappend maincommands {*}$ln
}
} }
#fossil output was ordered in columns, but we loaded list in row-wise, messing up the order #fossil output was ordered in columns, but we loaded list in row-wise, messing up the order
set maincommands [lsort $maincommands] set maincommands [lsort $maincommands]
set allcmds [lsort $allcmds] set allcmds [lsort $allcmds]
set othercmds [punk::lib::ldiff $allcmds $maincommands] set othercmds [punk::lib::ldiff $allcmds $maincommands]
set fossil_setting_names [lsort [runout -n fossil help -s]]
set result "@leaders -min 0\n" set result "@leaders -min 0\n"
append result [tstr -return string { append result [tstr -return string {
subcommand -type string -choicecolumns 8 -choicegroups { subcommand -type string -choicecolumns 8 -choicegroups {
"frequently used commands" {${$maincommands}} "frequently used commands" {${$maincommands}}
"" {${$othercmds}} "" {${$othercmds}}
} -choiceinfo {add {{doctype punkargs}} diff {{doctype punkargs}}} } -choiceprefixreservelist {${$fossil_setting_names}} -choiceinfo {add {{doctype punkargs}} diff {{doctype punkargs}}}
}] }]
#-choiceinfo { #-choiceinfo {
# add {{doctype punkargs}} # add {{doctype punkargs}}
@ -132,20 +147,127 @@ namespace eval punk::repo {
#experiment #experiment
lappend PUNKARGS [list {
@dynamic proc get_fossil_subcommand_usage {subcmd} {
@id -id "::punk::repo::fossil_proxy diff" set result ""
@cmd -name "fossil diff" -help "fossil diff" append result "@leaders -min 0 -max 0\n"
@formdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}} append result "@opts\n"
} ""] #The -o output sometimes includes portions of the general help text that happens to describe options.
#e.g fossil help diff -o includes
# "--webpage -y HTML output in the side-by-side format"
#as well as:
#" --webpage Format output as a stand-alone HTML webpage"
# we also get duplicates for --tk --by -b -y
#this suggests -o just does a basic parsing of the usage text and pulls out anything that looks like an option.
#other commands such as: fossil help fdiff -o
# return no options - but the help text states that fdiff accepts the same options as diff.
set basic_opt_lines [split [runout -n fossil help $subcmd -o] \n]
set help_lines [split [runout -n fossil help $subcmd] \n]
#first set of lines are for Usage:
#e.g
# % fossil help diff
# Usage: fossil diff|gdiff ?OPTIONS? FILE1 ?FILE2 ...?
# % fossil help ls
# Usage: fossil ls ?OPTIONS? ?PATHS ...?
#When there are multiple forms of usage we may get some "or:" lines.
#e.g
# % fossil help commit
# Usage: fossil commit ?OPTIONS? ?FILE...?
# or: fossil ci ?OPTIONS? ?FILE...?
# % fossil help mv
# Usage: fossil mv|rename ?OPTIONS? OLDNAME NEWNAME
# or: fossil mv|rename ?OPTIONS? OLDNAME... DIR
#(at least some "unsupported" test- commands don't provide a Usage line at all - e.g fossil help test-http)
foreach ln $basic_opt_lines {
set ln [string trim $ln]
if {$ln eq ""} {
continue
}
#the truncated description lines aren't useful here - but are always separated from the option info by more than one space.
set colbreak [string first " " $ln] ;#first occurrence of 2 spaces in a row - which is the separator between option info and description in fossil help output
set optinfo [string range $ln 0 $colbreak-1]
#this isn't the full help info for the option - but it's what we have available in the output of 'fossil help subcmd -o' - which is more concise and easier to parse than the full help for each option.
#todo - call fossil help <subcmd> and retrieve full help for each option.
set temphelp [string range $ln $colbreak end]
set opthelp [string trim $temphelp]
#we expect either one or two parts.
lassign $optinfo namepart typepart
#e.g --case-sensitive BOOL
#e.g -v|--verbose
#e.g -ci|--checkin VERSION (convert to -ci|--checkin=|--checkin -type VERSION)
if {$typepart ne ""} {
set optnames [split $namepart "|"]
#rebuild optnames as punkoptiondef string retaining dashes and pipes but adding in additional forms for longopts - e.g -ci|--checkin becomes -ci|--checkin=|--checkin
set punknames [list]
foreach n $optnames {
if {[string match --* $n]} {
#set n [list $n [string range $n 2 end]= [string range $n 2 end]]
lappend punknames $n ${n}=
} elseif {[string match -* $n]} {
lappend punknames $n
} else {
error "Unexpected option format: $n"
}
}
set typepart "-type $typepart"
} else {
#use as is if the flag doesn't have an argument - e.g -v|--verbose
set punknames $namepart
set typepart "-type none"
}
set punkoptiondef [join $punknames "|"]
append result [tstr -return string {
${$punkoptiondef} ${$typepart} -help {${$opthelp}}
}]
}
append result [tstr -return string {
@values -min 1 -max -1
file -type string -multiple 1 -help "file or directory to add to fossil"
}]
return $result
}
lappend PUNKARGS [list { lappend PUNKARGS [list {
#todo - remove this comment - testing dynamic directive #todo - remove this comment - testing dynamic directive
@dynamic @dynamic
@id -id "::punk::repo::fossil_proxy add" @id -id "::punk::repo::fossil_proxy add"
@cmd -name "fossil add" -help "fossil add @cmd -name "fossil add"\
" -summary\
""\
-help "fossil add"
@form -form "parsed"
${[punk::repo::get_fossil_subcommand_usage add]}
@form -form "raw" -synopsis "exec fossil add ?OPTIONS? FILE1 ?FILE2 ...?"
@formdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} @formdisplay -header "fossil help add" -body {${[runout -n fossil help add]}}
} ""] } ""]
lappend PUNKARGS [list {
@id -id "::punk::repo::fossil_proxy diff"
@cmd -name "fossil diff"\
-summary\
""\
-help\
"fossil diff"
@form -form "parsed"
${[punk::repo::get_fossil_subcommand_usage diff]}
@form -form "raw" -synopsis "exec fossil diff ?OPTIONS? FILE1 ?FILE2 ...?"
@formdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}}
} ""]
#TODO #TODO
#lappend PUNKARGS [list { #lappend PUNKARGS [list {
# @dynamic # @dynamic

225
src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/mashopts.test

@ -0,0 +1,225 @@
package require tcltest
namespace eval ::testspace {
namespace import ::tcltest::*
variable common {
set result ""
}
#test mash opts aka "option clustering" aka "flag stacking" aka "option combining" aka "short flag bundling" etc.
test mashopts_default {Test basic combining of short options when -mash set as default for short flags on @opts directive}\
-setup $common -body {
#first test they work individually as normal
set argd [punk::args::parse {-a -b -c} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none}]
lappend result [dict get $argd opts]
#test all combined
set argd [punk::args::parse {-abc} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none}]
lappend result [dict get $argd opts]
#varying order of flags in mash should still work
set argd [punk::args::parse {-cab} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none}]
lappend result [dict get $argd opts]
#repeating flags in mash should still work and be treated as if they were repeated separately (ie -aa should be treated as if it were -a -a)
#in this case we have not configured any of the flags to be multiple, so the second occurrence of each flag should just override the first occurrence and have no effect
set argd [punk::args::parse {-caba} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none}]
lappend result [dict get $argd opts]
#order of flags in the result should be the same as the order of flags in the definition of the optionset,
#not the order in which they were supplied in the mash - this is because we want the result to be deterministic and not depend on the order in which the user happened to combine the flags in the mash
#the actual order should be reflected in the received list.
set argd [punk::args::parse {-caba} withdef {@opts -mash 1} {-c -type none} {-a -type none} {-b -type none}]
lappend result [dict get $argd opts]
#the received list should show the repeated -a even though it's not set for multiple.
lappend result [dict get $argd received]
}\
-cleanup {
}\
-result [list\
{-a 1 -b 1 -c 1}\
{-a 1 -b 1 -c 1}\
{-a 1 -b 1 -c 1}\
{-a 1 -b 1 -c 1}\
{-c 1 -a 1 -b 1}\
{-c 0 -a 1 -b 2 -a 3}\
]
test mashopts_default_with_multiple {Test combining of short options when -mash set as default for short flags on @opts directive and a flag is set to -multiple}\
-setup $common -body {
#first test they work individually as normal
set argd [punk::args::parse {-a -b -c} withdef {@opts -mash 1} {-a -type none} {-b -type none -multiple true} {-c -type none}]
lappend result [dict get $argd opts]
set argd [punk::args::parse {-cba} withdef {@opts -mash 1} {-a -type none} {-b -type none -multiple true} {-c -type none}]
lappend result [dict get $argd opts]
#test a repeated flag within the mash
set argd [punk::args::parse {-cbba} withdef {@opts -mash 1} {-a -type none} {-b -type none -multiple true} {-c -type none}]
lappend result [dict get $argd opts]
#test a repeated flag after the mash
set argd [punk::args::parse {-cba -b} withdef {@opts -mash 1} {-a -type none} {-b -type none -multiple true} {-c -type none}]
lappend result [dict get $argd opts]
#test a repeated flag before the mash
set argd [punk::args::parse {-b -cba} withdef {@opts -mash 1} {-a -type none} {-b -type none -multiple true} {-c -type none}]
lappend result [dict get $argd opts]
#test a repeated flag before and after the mash
set argd [punk::args::parse {-b -cba -b} withdef {@opts -mash 1} {-a -type none} {-b -type none -multiple true} {-c -type none}]
lappend result [dict get $argd opts]
#test a repeated flag before, within and after the mash
set argd [punk::args::parse {-b -cbab -b} withdef {@opts -mash 1} {-a -type none} {-b -type none -multiple true} {-c -type none}]
lappend result [dict get $argd opts]
}\
-cleanup {
}\
-result [list\
{-a 1 -b 1 -c 1}\
{-a 1 -b 1 -c 1}\
{-a 1 -b {1 1} -c 1}\
{-a 1 -b {1 1} -c 1}\
{-a 1 -b {1 1} -c 1}\
{-a 1 -b {1 1 1} -c 1}\
{-a 1 -b {1 1 1 1} -c 1}\
]
test mashopts_default_with_typed_shortflag {Test combining of short options when -mash set as default for short flags on @opts directive and a shortopt accepts a value}\
-setup $common -body {
#test individually
set argd [punk::args::parse {-a -b -f fff -c} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none} {-f -type string}]
lappend result [dict get $argd opts]
#test with mash - the flag that accepts a value must be at the end of the mash.
set argd [punk::args::parse {-bacf fff} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none} {-f -type string}]
lappend result [dict get $argd opts]
#should error if the flag that accepts a value is not at the end of the mash, because that would be ambiguous - we would not know which flag the value belongs to
if {[catch {punk::args::parse {-bafc fff} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none} {-f -type string}} err]} {
lappend result "expected-error"
} else {
lappend result "missing-expected-error"
}
#failing to provide a value for -f should raise an error.
if {[catch {punk::args::parse {-bacf} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none} {-f -type string}} err]} {
lappend result "expected-error"
} else {
lappend result "missing-expected-error"
}
}\
-cleanup {
}\
-result [list\
{-a 1 -b 1 -c 1 -f fff}\
{-a 1 -b 1 -c 1 -f fff}\
expected-error\
expected-error\
]
test mashopts_default_with_other_flags {Test combining of short options when -mash set as default for short flags on @opts directive plus a longer value-accepting flag and a value}\
-setup $common -body {
#test individually
set argd [punk::args::parse {-a -b -f fff -c -cabinet ccc ttt} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none} {-f -type string} {-cabinet -type string} @values tail]
lappend result [dict get $argd opts]
lappend result [dict get $argd values]
#should error if the non-mash flag that accepts a value is supplied with a prefix shorter than the number of mash flags.
#(we don't calculate prefixes based on a possibly huge combination of mash flags, so we simply require prefixes for non-mash flags to be at least as long as the number of mash flags)
if {[catch {punk::args::parse {-bacf fff -cabi ccc ttt} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none} {-f -type string} {-cabinet -type string} @values tail} err]} {
lappend result "expected-error"
} else {
lappend result "missing-expected-error"
}
#we have 4 mash flags here, so a unique prefix of cabinet that is 5 long should be accepted.
set argd [punk::args::parse {-cabf fff -c -cabin ccc ttt} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none} {-f -type string} {-cabinet -type string} @values {tail -multiple 1 -optional 1}]
lappend result [dict get $argd opts]
lappend result [dict get $argd values]
#test it's not confused by a short prefix of cabinet that matches only mash flags.
#-cab should be processed as match flags - not a prefix of cabinet.
set argd [punk::args::parse {-cabf fff -c -cab ccc ttt} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none} {-f -type string} {-cabinet -type string} @values {tail -multiple 1 -optional 1}]
lappend result [dict get $argd opts]
lappend result [dict get $argd values]
}\
-cleanup {
}\
-result [list\
{-a 1 -b 1 -c 1 -f fff -cabinet ccc}\
{tail ttt}\
expected-error\
{-a 1 -b 1 -c 1 -f fff -cabinet ccc}\
{tail ttt}\
{-a 1 -b 1 -c 1 -f fff}\
{tail {ccc ttt}}\
]
test mashopts_mix_default_and_explicit {Test combining of short options when -mash set both on @opts and directly}\
-setup $common -body {
#-c no longer allowed in mash
set argd [punk::args::parse {-a -b -f fff -c -cabinet ccc ttt} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none -mash 0} {-f -type string} {-cabinet -type string} @values tail]
lappend result [dict get $argd opts]
lappend result [dict get $argd values]
set argd [punk::args::parse {-abf fff -c -cabinet ccc ttt} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none -mash 0} {-f -type string} {-cabinet -type string} @values tail]
lappend result [dict get $argd opts]
lappend result [dict get $argd values]
#attempting to mash -c should raise an error.
if {[catch {punk::args::parse {-bacf fff -cabinet ccc ttt} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none -mash 0} {-f -type string} {-cabinet -type string} @values tail} err]} {
lappend result "expected-error"
} else {
lappend result "missing-expected-error"
}
#test with only explicit -mash 1 on individual flags.
set argd [punk::args::parse {-abf fff -c -cabinet ccc ttt} withdef @opts {-a -type none -mash 1} {-b -type none -mash 1} {-c -type none} {-f -type string -mash 1} {-cabinet -type string} @values tail]
lappend result [dict get $argd opts]
lappend result [dict get $argd values]
#attempting to explicitly apply -mash 1 to -cabinet should raise an error because -cabinet is not a short flag and we only allow -mash 1 to be applied to short flags.
#(default -mash 1 on @opts is different as it is automatically only propagated to short flags.)
if {[catch {punk::args::parse {-acbf fff -cabinet ccc ttt} withdef @opts {-a -type none -mash 1} {-b -type none -mash 1} {-c -type none} {-f -type string -mash 1} {-cabinet -type string -mash 1} @values tail} err]} {
lappend result "expected-error"
} else {
lappend result "missing-expected-error"
}
#-c should default to not being mashable, so attempting to mash it should raise an error.
if {[catch {punk::args::parse {-acbf fff -cabinet ccc ttt} withdef @opts {-a -type none -mash 1} {-b -type none -mash 1} {-c -type none} {-f -type string -mash 1} {-cabinet -type string} @values tail} err]} {
lappend result "expected-error"
} else {
lappend result "missing-expected-error"
}
}\
-cleanup {
}\
-result [list\
{-a 1 -b 1 -c 1 -f fff -cabinet ccc}\
{tail ttt}\
{-a 1 -b 1 -c 1 -f fff -cabinet ccc}\
{tail ttt}\
expected-error\
{-a 1 -b 1 -c 1 -f fff -cabinet ccc}\
{tail ttt}\
expected-error\
expected-error\
]
}

0
src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/tests/mashopts.test#..+args+mashopts.test.fauxlink

537
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm

@ -665,6 +665,8 @@ tcl::namespace::eval punk::args {
%B%@opts%N% ?opt val...? %B%@opts%N% ?opt val...?
directive-options: -any|-arbitrary <bool> directive-options: -any|-arbitrary <bool>
(also accepts options as defaults for subsequent flag definitions) (also accepts options as defaults for subsequent flag definitions)
e.g -mash 1 - default to single letter flags to be mashable/combinable
(-abc instead of -a -b -c)
%B%@values%N% ?opt val...? %B%@values%N% ?opt val...?
(used for trailing args that come after switches/opts) (used for trailing args that come after switches/opts)
directive-options: -min <int> -max <int> -unnamed <bool> directive-options: -min <int> -max <int> -unnamed <bool>
@ -813,6 +815,22 @@ tcl::namespace::eval punk::args {
Further unambiguous arrangements of optional args may be Further unambiguous arrangements of optional args may be
made in future - but are currently considered 'unsupported' made in future - but are currently considered 'unsupported'
-default <value> -default <value>
-mash <bool> (for flags/switches only)
Option clustering, flag stacking, option mashing
- all refer to the same thing:
Whether single letter flags can be mashed together.
E.g -abc instead of -a -b -c
This defaults to false, but can be set to true for all
single-letter flags by setting -mash true on the @opts directive.
It is an error to explicitly set -mash true on a flag that doesn't
have a single letter as part it's name.
(e.g it is ok on -f or even -f|--flag)
When such flags are combined, only the last one can take a value.
E.g with -mash true and flags -a -b and -c that take no values,
and -f that takes a value:
-abc is valid and equivalent to -a -b -c
-abcf <value> is valid and equivalent to -a -b -c -f <value>
but -afc <value> is not valid
-multiple <bool> (for leaders & values defines whether -multiple <bool> (for leaders & values defines whether
subsequent received values are stored against the same subsequent received values are stored against the same
argument name - only applies to final leader OR final value) argument name - only applies to final leader OR final value)
@ -1008,6 +1026,7 @@ tcl::namespace::eval punk::args {
-validate_ansistripped 0\ -validate_ansistripped 0\
-strip_ansi 0\ -strip_ansi 0\
-nocase 0\ -nocase 0\
-mash 0\
-choiceprefix 1\ -choiceprefix 1\
-choicerestricted 1\ -choicerestricted 1\
-choicemultiple {1 1}\ -choicemultiple {1 1}\
@ -1065,6 +1084,8 @@ tcl::namespace::eval punk::args {
OPT_MIN ""\ OPT_MIN ""\
OPT_MAX ""\ OPT_MAX ""\
OPT_SOLOS {}\ OPT_SOLOS {}\
OPT_MASHES {}\
OPT_ALL_MASH_LETTERS {}\
OPTSPEC_DEFAULTS $optdirective_defaults\ OPTSPEC_DEFAULTS $optdirective_defaults\
OPT_CHECKS_DEFAULTS {}\ OPT_CHECKS_DEFAULTS {}\
OPT_GROUPS {}\ OPT_GROUPS {}\
@ -1548,15 +1569,18 @@ tcl::namespace::eval punk::args {
"" - # {continue} "" - # {continue}
} }
incr record_number incr record_number
if {[catch {lassign $trimrec firstword}]} { #after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict
if {[catch {set record_values [lassign $trimrec firstword]}]} {
puts stdout "----------------------------------------------" puts stdout "----------------------------------------------"
puts stderr "rec: $rec" puts stderr "rec: $rec"
set ::testrecord $rec set ::testrecord $rec
puts stdout "----------------------------------------------" puts stdout "----------------------------------------------"
puts "records: $records" puts "records: $records"
puts stdout "==============================================" puts stdout "=============================================="
error "punk::args::resolve - bad optionspecs line - unable to parse first word of record '$trimrec' id:$DEF_definition_id"
} }
set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict #set record_values [lassign $trimrec firstword]
if {[llength $record_values] % 2 != 0} { if {[llength $record_values] % 2 != 0} {
#todo - avoid raising an error - store invalid defs keyed on id #todo - avoid raising an error - store invalid defs keyed on id
error "punk::args::resolve - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" error "punk::args::resolve - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id"
@ -1808,6 +1832,14 @@ tcl::namespace::eval punk::args {
#set opt_any $v #set opt_any $v
tcl::dict::set F $fid OPT_ANY $v tcl::dict::set F $fid OPT_ANY $v
} }
-mash {
#default for single letter options that can be mashed together - e.g -a -b can be supplied as -ab if -mash is 1
#check is bool
if {![string is boolean -strict $v]} {
error "punk::args::resolve - Option '$k' has value '$v'of wrong type in @opts line. Must be boolean @id:$DEF_definition_id"
}
tcl::dict::set tmp_optspec_defaults $k $v
}
-min { -min {
dict set F $fid OPT_MIN $v dict set F $fid OPT_MIN $v
} }
@ -1918,7 +1950,7 @@ tcl::namespace::eval punk::args {
} }
default { default {
set known { -parsekey -group -grouphelp\ set known { -parsekey -group -grouphelp\
-any -anyopts -arbitrary -form -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo\ -any -anyopts -mash -arbitrary -form -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo\
-type -range -typeranges -default -defaultdisplaytype -typedefaults -type -range -typeranges -default -defaultdisplaytype -typedefaults
-choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted -nocase\ -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted -nocase\
-unindentedfields\ -unindentedfields\
@ -2402,6 +2434,8 @@ tcl::namespace::eval punk::args {
foreach fid $record_form_ids { foreach fid $record_form_ids {
if {$is_opt} { if {$is_opt} {
#OPTSPEC_DEFAULTS are the base defaults for options - these can be overridden by @opts lines
#we may still need to test some of these defaults for validity, e.g -mash true can only apply if the argname has at least one single-character alias (e.g -x or -x|--xxx)
set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS] set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS]
} else { } else {
if {[dict get $F $fid argspace] eq "values"} { if {[dict get $F $fid argspace] eq "values"} {
@ -2518,6 +2552,25 @@ tcl::namespace::eval punk::args {
-parsekey - -group { -parsekey - -group {
tcl::dict::set spec_merged -typesynopsis $specval tcl::dict::set spec_merged -typesynopsis $specval
} }
-mash {
#allow when any alt in argname is a single letter flag such s -a or -Z
#single letter flags do not have to be -type none to allow -mash to be set true.
#a mash can be supplied where the last flag in the mash is a value-taking flag.
if {$specval} {
set has_single_letter_flag 0
foreach alias $optaliases {
if {[string length $alias] == 2 && [string match -* $alias]} {
set has_single_letter_flag 1
break
}
}
if {!$has_single_letter_flag} {
error "punk::args::resolve - invalid use of -mash for argument '$argname'. -mash can only be true if at least one alias in the argname is a single-letter flag (e.g -a or -Z) @id:$DEF_definition_id"
#todo - we also have to set -mash false when processing defaults from @opts if the argname doesn't contain any single-letter flags
}
}
tcl::dict::set spec_merged -mash $specval
}
-unindentedfields - -unindentedfields -
-solo - -solo -
-choices - -choicegroups - -choicemultiple - -choicecolumns - -choices - -choicegroups - -choicemultiple - -choicecolumns -
@ -2661,6 +2714,30 @@ tcl::namespace::eval punk::args {
if {[tcl::dict::get $spec_merged -type] eq "none"} { if {[tcl::dict::get $spec_merged -type] eq "none"} {
dict set F $fid OPT_SOLOS [list {*}[dict get $F $fid OPT_SOLOS] $argname] dict set F $fid OPT_SOLOS [list {*}[dict get $F $fid OPT_SOLOS] $argname]
} }
if {[tcl::dict::get $spec_merged -mash]} {
#The value for -mash might be true only due to a default from @opts - in which case we need to check the argname for validity of -mash as described above and if not valid, set -mash false in the ARG_INFO for this argname
if {$argname eq "--"} {
#force -mash false - in case no -mash was specified on the flag itself and @opts -mash is true
tcl::dict::set spec_merged -mash false
} else {
set has_single_letter_flag 0
foreach alias $optaliases {
if {[string length $alias] == 2 && [string match -* $alias]} {
set has_single_letter_flag 1
break
}
}
if {!$has_single_letter_flag} {
#force -mash false in ARG_INFO for this argname - in case no -mash was specified and @opts -mash is true by default but argname doesn't contain any single-letter flags
tcl::dict::set spec_merged -mash false
}
}
#re-test state of -mash after any adjustments based on argname validity and defaults
if {[tcl::dict::get $spec_merged -mash]} {
#we add the whole argname with all aliases to the OPT_MASHES list - this is used during parsing to check if any of the aliases for a given flag are mashable
dict set F $fid OPT_MASHES [list {*}[dict get $F $fid OPT_MASHES] $argname]
}
}
} else { } else {
tcl::dict::set F $fid ARG_CHECKS $argname\ tcl::dict::set F $fid ARG_CHECKS $argname\
[tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi -choicecolumns -group -typesynopsis -help -ARGTYPE] ;#leave things like -range -minsize [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi -choicecolumns -group -typesynopsis -help -ARGTYPE] ;#leave things like -range -minsize
@ -2716,6 +2793,21 @@ tcl::namespace::eval punk::args {
#now cycle through ALL forms not just form_ids_active (record_form_ids) #now cycle through ALL forms not just form_ids_active (record_form_ids)
dict for {fid formdata} $F { dict for {fid formdata} $F {
set mashargs [dict get $F $fid OPT_MASHES]
if {[llength $mashargs]} {
#precalculate OPT_ALL_MASH_LETTERS
set all_mash_letters [list]
foreach fullopt $mashargs {
foreach flagpart [split $fullopt |] {
if {[string length $flagpart] == 2 && [string match -* $flagpart]} {
lappend all_mash_letters [string index $flagpart 1]
}
}
}
dict set F $fid OPT_ALL_MASH_LETTERS $all_mash_letters
}
if {[tcl::dict::get $F $fid OPT_MAX] eq ""} { if {[tcl::dict::get $F $fid OPT_MAX] eq ""} {
if {[llength [tcl::dict::get $F $fid OPT_NAMES]] == 0 && ![tcl::dict::get $F $fid OPT_ANY]} { if {[llength [tcl::dict::get $F $fid OPT_NAMES]] == 0 && ![tcl::dict::get $F $fid OPT_ANY]} {
tcl::dict::set F $fid OPT_MAX 0 ;#aid in parsing to avoid scanning for opts unnecessarily tcl::dict::set F $fid OPT_MAX 0 ;#aid in parsing to avoid scanning for opts unnecessarily
@ -3292,8 +3384,8 @@ tcl::namespace::eval punk::args {
return true return true
} }
foreach d $rawdef { foreach d $rawdef {
if {[regexp {\s*(\S+)} $d _match firstword]} { if {[regexp {\s*(\S+)} $d _match first_rawdef_word]} {
if {$firstword eq "@dynamic"} { if {$first_rawdef_word eq "@dynamic"} {
return true return true
} }
} }
@ -3513,7 +3605,7 @@ tcl::namespace::eval punk::args {
} }
# -- --- --- --- --- --- # -- --- --- --- --- ---
set unscanned [punklib_ldiff $registered $scanned_packages] set unscanned [punk::args::system::punklib_ldiff $registered $scanned_packages]
if {[llength $unscanned]} { if {[llength $unscanned]} {
foreach pkgns $unscanned { foreach pkgns $unscanned {
set idcount 0 set idcount 0
@ -3562,7 +3654,7 @@ tcl::namespace::eval punk::args {
if {"*" in $nslist} { if {"*" in $nslist} {
set needed [punklib_ldiff $registered $loaded_packages] set needed [punk::args::system::punklib_ldiff $registered $loaded_packages]
} else { } else {
set needed [list] set needed [list]
foreach pkgns $nslist { foreach pkgns $nslist {
@ -4311,6 +4403,33 @@ tcl::namespace::eval punk::args {
set trie [punk::trie::trieclass new {*}$all_opts --] set trie [punk::trie::trieclass new {*}$all_opts --]
set idents [dict get [$trie shortest_idents ""] scanned] set idents [dict get [$trie shortest_idents ""] scanned]
if {[llength [dict get $form_dict OPT_MASHES]]} {
set all_mash_letters [dict get $form_dict OPT_ALL_MASH_LETTERS]
#now extend idents to be at least as long as the number of mash/bundle flags that exist.
#(when the flag itself is longer than number of mash flags
# - e.g for flags -x -v -c -f -collection, the ident for -collection would be -co normally
# but if we have 4 mash flags, we want it to be -colle to satisfy the requirement that it is longer then the number of mash flags
# unless it is an exact match.)
#
#e.g if all the single letter flags are configured with -mash true:
#our prefix calculation might give us the following idents:
# idents: -cabinet -ca -a -a -b -b -c -c -- --
#we need only to extend -cabinet to -cabi to satisfy the requirement that it is longer than the number of mash flags (3 in this example because -- is never a mash flag)
dict for {fullname ident} $idents {
set mashcount [llength $all_mash_letters]
#assert: if we are here - mashcount > 0
if {[string length $ident] < [string length $fullname] && [string length $ident] <= $mashcount} {
dict set idents $fullname [string range $fullname 0 $mashcount+1]
}
}
#note it's still possible for the user to define a flag with a name shorter than the number of mash flags
# and it could even overlap with a specific combination of mash letters - e.g -a -b -c -d and a flag named -bac
# - in this case a provided value of -bac would still match the flag -bac rather than being treated as a mash of -b -a -c
#because the exact match will take priority over the prefix match.
#Whilst this configuration is accepted - it's not recommended.
}
#todo - check opt_prefixdeny #todo - check opt_prefixdeny
$trie destroy $trie destroy
@ -7906,6 +8025,8 @@ tcl::namespace::eval punk::args {
#set OPT_MIN [dict get $formdict OPT_MIN] #set OPT_MIN [dict get $formdict OPT_MIN]
set OPT_MAX [dict get $formdict OPT_MAX] set OPT_MAX [dict get $formdict OPT_MAX]
#set OPT_SOLOS [dict get $formdict OPT_SOLOS] #set OPT_SOLOS [dict get $formdict OPT_SOLOS]
set OPT_MASHES [dict get $formdict OPT_MASHES]
set OPT_ALL_MASH_LETTERS [dict get $formdict OPT_ALL_MASH_LETTERS]
set OPTSPEC_DEFAULTS [dict get $formdict OPTSPEC_DEFAULTS] set OPTSPEC_DEFAULTS [dict get $formdict OPTSPEC_DEFAULTS]
set OPT_CHECKS_DEFAULTS [dict get $formdict OPT_CHECKS_DEFAULTS] set OPT_CHECKS_DEFAULTS [dict get $formdict OPT_CHECKS_DEFAULTS]
#set OPT_GROUPS [dict get $formdict OPT_GROUPS] #set OPT_GROUPS [dict get $formdict OPT_GROUPS]
@ -7956,8 +8077,11 @@ tcl::namespace::eval punk::args {
} }
} }
} }
#note all_opts will necessarily not include mashed flags (e.g -abc) when only -a -b -c are defined - but we will detect and break those down in the main loop below
set all_opts [dict keys $lookup_optset] set all_opts [dict keys $lookup_optset]
set ridx 0 set ridx 0
set rawargs_copy $rawargs set rawargs_copy $rawargs
set remaining_rawargs $rawargs set remaining_rawargs $rawargs
@ -8374,15 +8498,225 @@ tcl::namespace::eval punk::args {
#flagsupplied when --longopt=x is --longopt (may still be a prefix) #flagsupplied when --longopt=x is --longopt (may still be a prefix)
#get full flagname from possible prefix $flagsupplied #get full flagname from possible prefix $flagsupplied
set flagname [tcl::prefix match -error "" [list {*}$all_opts --] $flagsupplied] set flagname [tcl::prefix match -error "" [list {*}$all_opts --] $flagsupplied]
if {$flagname eq "--"} { #The prefix matching above doesn't consider that mashed flags can make shorter prefixes an invalid match for the whole flag.
set optionset "" #if the length of our matched flagname is less than the length of $OPT_ALL_MASH_LETTERS, then we may have a mash of other flags,
} else { #not a valid match for some longer flag that just happens to share the same prefix as the start of the mash.
if {[dict exists $lookup_optset $flagname]} { #we have defined valid prefix matches in the presence of mashed flags to be only those that are longer than any possible mash of flags
set optionset [dict get $lookup_optset $flagname]
} else { #(review - for small numbers of mashed flags we could be more precise, but the combinatoric explosion of longer mash lengths makes it
#simpler to just say any match that is shorter than the length of the longest possible mash is invalid
# we may need consider what common utilities do in practice regarding allowing prefixes in the presence of mashed flags
#- but it seems likely that they would either not allow prefixes at all, or only allow prefixes that are longer than any possible mash of flags)
#So if we have a match that isn't exact and is shorter than the length of the longest possible mash, we need to check if it's actually a mash of valid flags rather than a valid prefix match for a longer flag.
if {$flagname ne $flagsupplied && [llength $OPT_MASHES] && (([string length $flagsupplied] -1) <= [llength $OPT_ALL_MASH_LETTERS])} {
#invalidate the match
set flagname ""
}
switch -- $flagname {
-- {
set optionset "" set optionset ""
} }
"" {
#no match for flagname - could be a mashed flag e.g -abc where only -a -b -c are defined
if {![llength $OPT_MASHES]} {
#no mashed flags defined - so this probably isn't a flag - could be a value
set optionset ""
} else {
#check if every letter after the first matches a defined opt - if so treat as mashed flags
set mashflags [string range $flagsupplied 1 end]
set mashletters [split $mashflags ""]
set all_mashable true
foreach mf $mashletters {
if {$mf ni $OPT_ALL_MASH_LETTERS} {
set all_mashable false
break
}
}
#todo - move block below up here.
if {!$all_mashable} {
puts stderr "Debug: flagsupplied '$flagsupplied' not a valid flagname and not a valid mash of flags - treating as value"
#- probably isn't a flag at all - could be a value
#treat as value
set optionset ""
} else {
#puts stderr "Debug: flagsupplied '$flagsupplied' not a valid flagname but is a valid mash of flags - treating as mash of flags"
#treat as mashed flags - we will break down into individual flags and process each one in turn
set optionset $flagsupplied
#the -mash option means we may have to process multiple flags as received for one arg that looks like a flag
#we can still use the lookup_optset dict to get the optionset for each individual flag - as the keys of lookup_optset are all the individual flags (not mashed together)
#we need to update:
# vals_remaining_possible after processing all matchletters (by -1 or -2 depending on whether the mash includes a flag with an attached value (trailing=<val>) or accepts a value.)
# multisreceived
# soloreceived (if any of the flags in the mash are solo)
# flagsreceived (add the mash as received - but also add each individual flag in the mash as received for the purposes of checking for multiple and solo)
# opts (for each flag in the mash)
set posn 0
set consume_value 0 ;#if last mash flag accepts a value, we will consume the next arg as its value
foreach mf $mashletters {
set matchopt [dict get $lookup_optset -$mf]
if {$matchopt eq ""} {
#this should not happen as we have already checked all letters are mashable - but check just in case
puts stderr "Debug: mash letter '-$mf' not in lookup_optset - this should not happen"
} else {
#process each mashed flag as if it were received separately
#- we can reuse the same flagval for each as they won't be expected to have values (as they are single letter flags)
#we will still need to check for multiple and defaults for each individual flag
#we can also still use the same argstate entries for each individual flag as the optionset will be the same for each of the mashed flags (as they will all be defined in the same optionset e.g -a|-b|-c)
set mashflagname -$mf
set mashflagoptionset [dict get $lookup_optset $mashflagname]
set raw_optionset_members [split $mashflagoptionset |]
#set mashflagapiopt [dict get $argstate $mashflagoptionset -parsekey]
#if {$mashflagapiopt eq ""} {
# set mashflagapiopt [string trimright [lindex [split $mashflagoptionset |] end] =]
#}
set flagname -$mf
if {[tcl::dict::get $argstate $mashflagoptionset -parsekey] ne ""} {
set api_opt [dict get $argstate $mashflagoptionset -parsekey]
} else {
set api_opt [string trimright [lindex $raw_optionset_members end] =]
}
if {$api_opt eq $flagname} {
set flag_ident $api_opt
set flag_ident_is_parsekey 0
} else {
#initially key our opts on a long form allowing us to know which specific flag was used
#(for when multiple map to same parsekey e.g lsearch)
#e.g -increasing|-SORTOPTION
set flag_ident $flagname|$api_opt
set flag_ident_is_parsekey 1
}
set optionset_type [tcl::dict::get $argstate $mashflagoptionset -type]
#only the last flag in a mash can be allowed to have a value, and the other flags must be of type none.
#flags are by default optional.
if {$optionset_type ne "none"} {
#A flag with a value - only allowed for the last flag in a mash
if {$posn != [expr {[llength $mashletters] - 1}]} {
#not the last flag in the mash - can't have a value
set errmsg "bad options for %caller%. Flag \"$mashflagname\" in mash \"$flagsupplied\" cannot have a value as only the last flag in a mash can have a value. The flag \"$mashflagname\" must be of type none. (1)"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $all_opts] -badarg $a -argspecs $argspecs]] $errmsg
} else {
set consume_value 1
# ------------
#check if it was actually a value that looked like a flag
if {$i == $maxidx} {
#if no optvalue following - assume it's a value
#(caller should probably have used -- before it)
#review
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
break
}
#flagval comes from next remaining rawarg
set flagval [lindex $remaining_rawargs $i+1]
if {[tcl::dict::get $argstate $mashflagoptionset -multiple]} {
#don't lappend to default - we need to replace if there is a default
if {$api_opt ni $flagsreceived} {
tcl::dict::set opts $flag_ident [list $flagval]
} else {
tcl::dict::lappend opts $flag_ident $flagval
}
if {$api_opt ni $multisreceived} {
lappend multisreceived $api_opt
}
} else {
#tcl::dict::set opts $flag_ident $flagval
if {$flag_ident_is_parsekey} {
#necessary shimmer ?
lappend opts $flag_ident $flagval
} else {
tcl::dict::set opts $flag_ident $flagval
}
}
#incr i to skip flagval
#incr vals_remaining_possible -2
#if {[incr i] > $maxidx} {
# set msg "Bad options for %caller%. No value supplied for last option $mashflagoptionset at index [expr {$i-1}] which is not marked with -type none"
# return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $mashflagoptionset index [expr {$i-1}]] -badarg $mashflagoptionset -argspecs $argspecs]] $msg
#}
# ------------
}
} else {
#flag with no value - check for -typedefaults for the flag
#none / solo
if {[tcl::dict::exists $argstate $mashflagoptionset -typedefaults]} {
set tdflt [tcl::dict::get $argstate $mashflagoptionset -typedefaults]
} else {
#normal default for a solo is 1 unless overridden by -typedefaults
set tdflt 1
}
if {[tcl::dict::get $argstate $mashflagoptionset -multiple]} {
#puts stderr "Debug: flag '$mashflagname' in mash '$flagsupplied' is a multiple with typedefaults $tdflt -- api_opt: $api_opt flag_ident: $flag_ident flagsreceived: $flagsreceived multisreceived: $multisreceived"
if {$api_opt ni $flagsreceived} {
#override any default - don't lappend to it
tcl::dict::set opts $flag_ident $tdflt
} else {
tcl::dict::lappend opts $flag_ident $tdflt
}
if {$api_opt ni $multisreceived} {
lappend multisreceived $api_opt
}
} else {
#test parse_withdef_parsekey_repeat_ordering {Ensure last flag has precedence}
#tcl::dict::set opts $flag_ident $tdflt
if {$flag_ident_is_parsekey} {
#(shimmer - but required for ordering correctness during override)
puts stderr "Debug: flag '$mashflagname' in mash '$flagsupplied' flag_ident '$flag_ident' is the same as parsekey '$api_opt' tdflt: $tdflt - using lappend to ensure it ends up after any previous flag in the mash that had the same parsekey"
lappend opts $flag_ident $tdflt
puts stderr "opts after lappend: $opts"
} else {
tcl::dict::set opts $flag_ident $tdflt
}
}
#incr vals_remaining_possible -1
lappend solosreceived $api_opt ;#dups ok
}
}
lappend flagsreceived $api_opt
incr posn
}
#update vals_remaining_possible by one or 2 if the last flag took a value.
incr vals_remaining_possible -1
if {$flagval_included || $consume_value} {
incr vals_remaining_possible -1
}
#after processing the mash, we will have updated opts for each individual flag in the mash,
#and updated multisreceived and solo_received as needed based on the optionset entries for each individual flag in the mash
#we possibly need to incr i to skip a received value for the mash if the last flag in the mash had a value.
#or break if we have reached the end of the args after processing the mash
if {$flagval_included || $consume_value} {
#the last flag in the mash had a value - we have already processed it for that flag - so we need to skip it for the next iteration of the loop
incr i
if {$i > $maxidx} {
#we have reached the end of the args after processing the mash and its value - so we can break out of the loop
break
}
} else {
#no value included for the last flag in the mash - so we just continue to the next iteration of the loop to process the next arg
}
continue
}
}
}
default {
if {[dict exists $lookup_optset $flagname]} {
set optionset [dict get $lookup_optset $flagname]
} else {
#we matched a prefix of all_opts - but it's not in the lookup_optset?
#review - this should not happen as we only match prefixes from all_opts which is derived from the keys of lookup_optset
puts stderr "Debug: matched prefix '$flagname' not in lookup_optset - this should not happen"
set optionset ""
}
}
} }
if {$optionset ne ""} { if {$optionset ne ""} {
#matched some option - either in part or in full. #matched some option - either in part or in full.
set raw_optionset_members [split $optionset |] set raw_optionset_members [split $optionset |]
@ -9205,7 +9539,7 @@ tcl::namespace::eval punk::args {
#} #}
#for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us
if {[llength $LEADER_REQUIRED]} { if {[llength $LEADER_REQUIRED]} {
if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { if {[llength [set missing [punk::args::system::punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} {
set msg "Required leader missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" 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 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 #arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs
@ -9213,7 +9547,7 @@ tcl::namespace::eval punk::args {
} }
if {[llength $OPT_REQUIRED]} { if {[llength $OPT_REQUIRED]} {
set api_opt_required [lmap v $OPT_REQUIRED {lindex [split $v |] end}] set api_opt_required [lmap v $OPT_REQUIRED {lindex [split $v |] end}]
if {[llength [set missing [punklib_ldiff $api_opt_required $flagsreceived]]]} { if {[llength [set missing [punk::args::system::punklib_ldiff $api_opt_required $flagsreceived]]]} {
set full_missing [list] set full_missing [list]
foreach m $missing { foreach m $missing {
lappend full_missing [dict get $lookup_optset $m] lappend full_missing [dict get $lookup_optset $m]
@ -9225,7 +9559,7 @@ tcl::namespace::eval punk::args {
} }
} }
if {[llength $VAL_REQUIRED]} { if {[llength $VAL_REQUIRED]} {
if {[llength [set missing [punklib_ldiff $VAL_REQUIRED $valnames_received]]]} { if {[llength [set missing [punk::args::system::punklib_ldiff $VAL_REQUIRED $valnames_received]]]} {
set msg "Required value missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" 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 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 #arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs
@ -10026,8 +10360,8 @@ tcl::namespace::eval punk::args {
set alternates [list];#alternate acceptable types e.g literal(yes)|literal(ok) or indexpression|literal(first) set alternates [list];#alternate acceptable types e.g literal(yes)|literal(ok) or indexpression|literal(first)
set type_alternatives [_split_type_expression $tp] set type_alternatives [_split_type_expression $tp]
foreach tp_alternative $type_alternatives { foreach tp_alternative $type_alternatives {
set firstword [lindex $tp_alternative 0] set tp_alternative_word1 [lindex $tp_alternative 0]
switch -exact -- $firstword { switch -exact -- $tp_alternative_word1 {
literal { literal {
set match [lindex $tp_alternative 1] set match [lindex $tp_alternative 1]
lappend alternates $match lappend alternates $match
@ -11485,7 +11819,7 @@ tcl::namespace::eval punk::args::package {
-return\ -return\
-type string\ -type string\
-default table\ -default table\
-choices {string table tableobject}\ -choices {string table tableobject dict}\
-choicelabels { -choicelabels {
string\ string\
"A basic text layout" "A basic text layout"
@ -11564,19 +11898,25 @@ tcl::namespace::eval punk::args::package {
} }
} }
} }
if {$opt_return ne "string"} {
package require textblock ;#table support
set is_table 1
set title [string cat {[} $pkgname {]} ]
set t [textblock::class::table new -title $title]
$t configure -frametype double -minwidth [expr {[string length $title]+2}]
} else { set is_table 0
set topiclens [lmap t $topics {string length $t}] switch -- $opt_return {
set widest_topic [tcl::mathfunc::max {*}$topiclens] table - tableobject {
set is_table 0 package require textblock ;#table support
set about "$pkgname\n" set is_table 1
append about [string repeat - $widest_topic] \n set title [string cat {[} $pkgname {]} ]
set t [textblock::class::table new -title $title]
$t configure -frametype double -minwidth [expr {[string length $title]+2}]
}
string {
set topiclens [lmap t $topics {string length $t}]
set widest_topic [tcl::mathfunc::max {*}$topiclens]
set about "$pkgname\n"
append about [string repeat - $widest_topic] \n
}
dict {
set about [dict create]
}
} }
foreach topic $topics { foreach topic $topics {
if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} {
@ -11584,14 +11924,20 @@ tcl::namespace::eval punk::args::package {
} else { } else {
set topic_contents "<unavailable>" set topic_contents "<unavailable>"
} }
if {!$is_table} { switch -- $opt_return {
set content_lines [split $topic_contents \n] table - tableobject {
append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n $t add_row [list $topic $topic_contents]
foreach ln [lrange $content_lines 1 end] { }
append about [format %-${widest_topic}s ""] " " $ln \n string {
set content_lines [split $topic_contents \n]
append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n
foreach ln [lrange $content_lines 1 end] {
append about [format %-${widest_topic}s ""] " " $ln \n
}
}
dict {
dict set about $topic $topic_contents
} }
} else {
$t add_row [list $topic $topic_contents]
} }
} }
@ -11662,6 +12008,121 @@ tcl::namespace::eval punk::args::system {
} }
# == === === === === === === === === === === === === === ===
# Sample 'about' function with punk::args documentation
# == === === === === === === === === === === === === === ===
tcl::namespace::eval punk::args {
namespace eval argdoc {
#namespace for custom argument documentation
namespace import ::punk::args::helpers::*
proc package_name {} {
return punk::args
}
proc about_topics {} {
#info commands results are returned in an arbitrary order (like array keys)
set topic_funs [info commands [namespace current]::get_topic_*]
set about_topics [list]
foreach f $topic_funs {
set tail [namespace tail $f]
lappend about_topics [string range $tail [string length get_topic_] end]
}
#Adjust this function or 'default_topics' if a different order is required
return [lsort $about_topics]
}
proc default_topics {} {return [list Description *]}
# -------------------------------------------------------------
# get_topic_ functions add more to auto-include in about topics
# -------------------------------------------------------------
proc get_topic_Description {} {
punk::args::lib::tstr -indent " " [string trim {
package punk::args
Argument parsing library for Tcl.
Can be used purely for documentation of arguments and options, or also for actual argument parsing in procs.
supports longopts-style options, subcommands, and generation of help text.
"mash options" aka "short option bundling" or "flag/option stacking"
punk::args supports mash options for single letter flags that don't take arguments, e.g -a -b -c -> -abc or -bac etc
The last option in a mash can take an argument, e.g -x -v -f <filename> -> -xvf <filename>
Note the number of permutations of options with mashing can get large quickly.
(e.g 10 flags would have 10! = 3,628,800 permutations if all could be mashed together)
This has implications if we also support unique abbreviations of options as every permutation of the mashing
would need to be checked for conflicts with other options and their abbreviations.
The chosen solution is to determine the longest possible mashes for a given set of options, and then require
any abbreviations of other -options to be longer than the longest mash, so that there is no ambiguity between
an abbreviation and a mash.
E.g if we have -mash true and the options -a -b -c -d -backwards -cabinet -call, then the longest mash/bundle is 4 chars
(-abcd -bacd etc), so using the longest mash/bundle length of 4, we require that any abbreviation of other options must be at
least 5 chars long.
In this case -backwards could be abbreviated to -backw or -backwa etc, but not to -ba, -bac or -back.
As an exact match; -call would be accepted.
Whilst in this specific case -back is theoretically unambiguous - we still stick to the rule of requiring abbreviations to be
longer than the longest mash, to keep the rules simple and consistent; and so easier to process and to predict and reason about.
Although the combinations of -a -b -c -d are manageable in this case, if we had more single-letter options we would
not want to use a huge number of combinations of mashes to calculate the allowable prefix matches.
we calculate prefixes based on the flag names as usual, but extend the required prefixes of options such as -cabinet to be longer
(-cab extended to -cabin, -cal extended to -call).
} \n]
}
proc get_topic_License {} {
return " BSD 3-Clause"
}
proc get_topic_Version {} {
return " $::punk::args::version"
}
proc get_topic_Contributors {} {
set authors {{Julian Noble <julian@precisium.com.au>}}
set contributors ""
foreach a $authors {
append contributors $a \n
}
if {[string index $contributors end] eq "\n"} {
set contributors [string range $contributors 0 end-1]
}
return [punk::lib::tstr -indent " " $contributors]
}
proc get_topic_notes {} {
punk::args::lib::tstr -indent " " -return string {
see output of:
punk::args::usage ::punk::args::parse
As a convenience in a shell with the various punk packages loaded, you can also do:
i punk::args::parse
Here i is an alias for punk::ns::cmdhelp which allows lookup of unqualified command names
based on the current context.
}
}
# -------------------------------------------------------------
}
# we re-use the argument definition from punk::args::standard_about and override some items
set overrides [dict create]
dict set overrides @id -id "::punk::args::about"
dict set overrides @cmd -name "punk::args::about"
dict set overrides @cmd -help [string trim [punk::args::lib::tstr {
About punk::args
}] \n]
dict set overrides topic -choices [list {*}[punk::args::argdoc::about_topics] *]
dict set overrides topic -choicerestricted 1
dict set overrides topic -default [punk::args::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *]
lappend PUNKARGS [list $newdef]
proc about {args} {
package require punk::args
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on
set argd [punk::args::parse $args withid ::punk::args::about]
lassign [dict values $argd] _leaders opts values _received
punk::args::package::standard_about -package_about_namespace ::punk::args::argdoc {*}$opts {*}[dict get $values topic]
}
}
# end of sample 'about' function
# == === === === === === === === === === === === === === ===
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready ## Ready

2
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm

@ -3315,7 +3315,7 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
Each element except ${$B}type${$N} is a decimal string with the value of the corresponding field from the Each element except ${$B}type${$N} is a decimal string with the value of the corresponding field from the
stat return structure; see the manual entry for stat for details on the meanings of the values. stat return structure; see the manual entry for stat for details on the meanings of the values.
The type element gives the type of the file in the same form returned by the command ${$B}file type${$N}." The type element gives the type of the file in the same form returned by the command ${$B}file type${$N}."
@values -min 1 -max 1 @values -min 1 -max 2
name -optional 0 -type string name -optional 0 -type string
varName -type string -optional 1 varName -type string -optional 1
} "@doc -name Manpage: -url [manpage_tcl file]"] } "@doc -name Manpage: -url [manpage_tcl file]"]

19
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/ns-0.1.0.tm

@ -54,12 +54,19 @@ tcl::namespace::eval punk::nav::ns {
n// p* - list namespaces below current and commands in current matching p* n// p* - list namespaces below current and commands in current matching p*
} }
@values -min 1 -max -1 -type string @values -min 1 -max -1 -type string
v -type string -choices {/ //} -help\ v -type string\
" -choices {/ // ///}\
/ - list namespaces only -choicelabels {
// - list namespaces and commands /\
/// - list namespaces, commands and commands resolvable via 'namespace path' "list namespaces only"
" //\
"list namespaces and commands"
///\
"list namespaces, commands and commands
resolvable via 'namespace path'"
}\
-help\
"The form of navigation/listing to perform."
nsglob -type string -optional true -multiple true -help\ nsglob -type string -optional true -multiple true -help\
"A glob pattern supporting placeholders * and ?, to filter results. "A glob pattern supporting placeholders * and ?, to filter results.
If multiple patterns are supplied, then a listing for each pattern is returned. If multiple patterns are supplied, then a listing for each pattern is returned.

148
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm

@ -85,25 +85,40 @@ namespace eval punk::repo {
set allcmds [runout -n fossil help -a] set allcmds [runout -n fossil help -a]
set mainhelp [runout -n fossil help] set mainhelp [runout -n fossil help]
set maincommands [list] set maincommands [list]
#only start parsing for TOPICS after a line such as "Other comman values for TOPIC:"
set parsing_topics 0
foreach ln [split $mainhelp \n] { foreach ln [split $mainhelp \n] {
set ln [string trim $ln] set ln [string trim $ln]
if {$ln eq "" || [regexp {^[A-Z]+} $ln]} { if {$ln eq ""} {
continue continue
} }
lappend maincommands {*}$ln if {[string match "*values for TOPIC*" $ln]} {
set parsing_topics 1
continue
}
if {$parsing_topics} {
#lines starting with uppercase are topic headers - we want to ignore these and any blank lines
if {[regexp {^[A-Z]+} $ln]} {
continue
}
lappend maincommands {*}$ln
}
} }
#fossil output was ordered in columns, but we loaded list in row-wise, messing up the order #fossil output was ordered in columns, but we loaded list in row-wise, messing up the order
set maincommands [lsort $maincommands] set maincommands [lsort $maincommands]
set allcmds [lsort $allcmds] set allcmds [lsort $allcmds]
set othercmds [punk::lib::ldiff $allcmds $maincommands] set othercmds [punk::lib::ldiff $allcmds $maincommands]
set fossil_setting_names [lsort [runout -n fossil help -s]]
set result "@leaders -min 0\n" set result "@leaders -min 0\n"
append result [tstr -return string { append result [tstr -return string {
subcommand -type string -choicecolumns 8 -choicegroups { subcommand -type string -choicecolumns 8 -choicegroups {
"frequently used commands" {${$maincommands}} "frequently used commands" {${$maincommands}}
"" {${$othercmds}} "" {${$othercmds}}
} -choiceinfo {add {{doctype punkargs}} diff {{doctype punkargs}}} } -choiceprefixreservelist {${$fossil_setting_names}} -choiceinfo {add {{doctype punkargs}} diff {{doctype punkargs}}}
}] }]
#-choiceinfo { #-choiceinfo {
# add {{doctype punkargs}} # add {{doctype punkargs}}
@ -132,20 +147,127 @@ namespace eval punk::repo {
#experiment #experiment
lappend PUNKARGS [list {
@dynamic proc get_fossil_subcommand_usage {subcmd} {
@id -id "::punk::repo::fossil_proxy diff" set result ""
@cmd -name "fossil diff" -help "fossil diff" append result "@leaders -min 0 -max 0\n"
@formdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}} append result "@opts\n"
} ""] #The -o output sometimes includes portions of the general help text that happens to describe options.
#e.g fossil help diff -o includes
# "--webpage -y HTML output in the side-by-side format"
#as well as:
#" --webpage Format output as a stand-alone HTML webpage"
# we also get duplicates for --tk --by -b -y
#this suggests -o just does a basic parsing of the usage text and pulls out anything that looks like an option.
#other commands such as: fossil help fdiff -o
# return no options - but the help text states that fdiff accepts the same options as diff.
set basic_opt_lines [split [runout -n fossil help $subcmd -o] \n]
set help_lines [split [runout -n fossil help $subcmd] \n]
#first set of lines are for Usage:
#e.g
# % fossil help diff
# Usage: fossil diff|gdiff ?OPTIONS? FILE1 ?FILE2 ...?
# % fossil help ls
# Usage: fossil ls ?OPTIONS? ?PATHS ...?
#When there are multiple forms of usage we may get some "or:" lines.
#e.g
# % fossil help commit
# Usage: fossil commit ?OPTIONS? ?FILE...?
# or: fossil ci ?OPTIONS? ?FILE...?
# % fossil help mv
# Usage: fossil mv|rename ?OPTIONS? OLDNAME NEWNAME
# or: fossil mv|rename ?OPTIONS? OLDNAME... DIR
#(at least some "unsupported" test- commands don't provide a Usage line at all - e.g fossil help test-http)
foreach ln $basic_opt_lines {
set ln [string trim $ln]
if {$ln eq ""} {
continue
}
#the truncated description lines aren't useful here - but are always separated from the option info by more than one space.
set colbreak [string first " " $ln] ;#first occurrence of 2 spaces in a row - which is the separator between option info and description in fossil help output
set optinfo [string range $ln 0 $colbreak-1]
#this isn't the full help info for the option - but it's what we have available in the output of 'fossil help subcmd -o' - which is more concise and easier to parse than the full help for each option.
#todo - call fossil help <subcmd> and retrieve full help for each option.
set temphelp [string range $ln $colbreak end]
set opthelp [string trim $temphelp]
#we expect either one or two parts.
lassign $optinfo namepart typepart
#e.g --case-sensitive BOOL
#e.g -v|--verbose
#e.g -ci|--checkin VERSION (convert to -ci|--checkin=|--checkin -type VERSION)
if {$typepart ne ""} {
set optnames [split $namepart "|"]
#rebuild optnames as punkoptiondef string retaining dashes and pipes but adding in additional forms for longopts - e.g -ci|--checkin becomes -ci|--checkin=|--checkin
set punknames [list]
foreach n $optnames {
if {[string match --* $n]} {
#set n [list $n [string range $n 2 end]= [string range $n 2 end]]
lappend punknames $n ${n}=
} elseif {[string match -* $n]} {
lappend punknames $n
} else {
error "Unexpected option format: $n"
}
}
set typepart "-type $typepart"
} else {
#use as is if the flag doesn't have an argument - e.g -v|--verbose
set punknames $namepart
set typepart "-type none"
}
set punkoptiondef [join $punknames "|"]
append result [tstr -return string {
${$punkoptiondef} ${$typepart} -help {${$opthelp}}
}]
}
append result [tstr -return string {
@values -min 1 -max -1
file -type string -multiple 1 -help "file or directory to add to fossil"
}]
return $result
}
lappend PUNKARGS [list { lappend PUNKARGS [list {
#todo - remove this comment - testing dynamic directive #todo - remove this comment - testing dynamic directive
@dynamic @dynamic
@id -id "::punk::repo::fossil_proxy add" @id -id "::punk::repo::fossil_proxy add"
@cmd -name "fossil add" -help "fossil add @cmd -name "fossil add"\
" -summary\
""\
-help "fossil add"
@form -form "parsed"
${[punk::repo::get_fossil_subcommand_usage add]}
@form -form "raw" -synopsis "exec fossil add ?OPTIONS? FILE1 ?FILE2 ...?"
@formdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} @formdisplay -header "fossil help add" -body {${[runout -n fossil help add]}}
} ""] } ""]
lappend PUNKARGS [list {
@id -id "::punk::repo::fossil_proxy diff"
@cmd -name "fossil diff"\
-summary\
""\
-help\
"fossil diff"
@form -form "parsed"
${[punk::repo::get_fossil_subcommand_usage diff]}
@form -form "raw" -synopsis "exec fossil diff ?OPTIONS? FILE1 ?FILE2 ...?"
@formdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}}
} ""]
#TODO #TODO
#lappend PUNKARGS [list { #lappend PUNKARGS [list {
# @dynamic # @dynamic

537
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm

@ -665,6 +665,8 @@ tcl::namespace::eval punk::args {
%B%@opts%N% ?opt val...? %B%@opts%N% ?opt val...?
directive-options: -any|-arbitrary <bool> directive-options: -any|-arbitrary <bool>
(also accepts options as defaults for subsequent flag definitions) (also accepts options as defaults for subsequent flag definitions)
e.g -mash 1 - default to single letter flags to be mashable/combinable
(-abc instead of -a -b -c)
%B%@values%N% ?opt val...? %B%@values%N% ?opt val...?
(used for trailing args that come after switches/opts) (used for trailing args that come after switches/opts)
directive-options: -min <int> -max <int> -unnamed <bool> directive-options: -min <int> -max <int> -unnamed <bool>
@ -813,6 +815,22 @@ tcl::namespace::eval punk::args {
Further unambiguous arrangements of optional args may be Further unambiguous arrangements of optional args may be
made in future - but are currently considered 'unsupported' made in future - but are currently considered 'unsupported'
-default <value> -default <value>
-mash <bool> (for flags/switches only)
Option clustering, flag stacking, option mashing
- all refer to the same thing:
Whether single letter flags can be mashed together.
E.g -abc instead of -a -b -c
This defaults to false, but can be set to true for all
single-letter flags by setting -mash true on the @opts directive.
It is an error to explicitly set -mash true on a flag that doesn't
have a single letter as part it's name.
(e.g it is ok on -f or even -f|--flag)
When such flags are combined, only the last one can take a value.
E.g with -mash true and flags -a -b and -c that take no values,
and -f that takes a value:
-abc is valid and equivalent to -a -b -c
-abcf <value> is valid and equivalent to -a -b -c -f <value>
but -afc <value> is not valid
-multiple <bool> (for leaders & values defines whether -multiple <bool> (for leaders & values defines whether
subsequent received values are stored against the same subsequent received values are stored against the same
argument name - only applies to final leader OR final value) argument name - only applies to final leader OR final value)
@ -1008,6 +1026,7 @@ tcl::namespace::eval punk::args {
-validate_ansistripped 0\ -validate_ansistripped 0\
-strip_ansi 0\ -strip_ansi 0\
-nocase 0\ -nocase 0\
-mash 0\
-choiceprefix 1\ -choiceprefix 1\
-choicerestricted 1\ -choicerestricted 1\
-choicemultiple {1 1}\ -choicemultiple {1 1}\
@ -1065,6 +1084,8 @@ tcl::namespace::eval punk::args {
OPT_MIN ""\ OPT_MIN ""\
OPT_MAX ""\ OPT_MAX ""\
OPT_SOLOS {}\ OPT_SOLOS {}\
OPT_MASHES {}\
OPT_ALL_MASH_LETTERS {}\
OPTSPEC_DEFAULTS $optdirective_defaults\ OPTSPEC_DEFAULTS $optdirective_defaults\
OPT_CHECKS_DEFAULTS {}\ OPT_CHECKS_DEFAULTS {}\
OPT_GROUPS {}\ OPT_GROUPS {}\
@ -1548,15 +1569,18 @@ tcl::namespace::eval punk::args {
"" - # {continue} "" - # {continue}
} }
incr record_number incr record_number
if {[catch {lassign $trimrec firstword}]} { #after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict
if {[catch {set record_values [lassign $trimrec firstword]}]} {
puts stdout "----------------------------------------------" puts stdout "----------------------------------------------"
puts stderr "rec: $rec" puts stderr "rec: $rec"
set ::testrecord $rec set ::testrecord $rec
puts stdout "----------------------------------------------" puts stdout "----------------------------------------------"
puts "records: $records" puts "records: $records"
puts stdout "==============================================" puts stdout "=============================================="
error "punk::args::resolve - bad optionspecs line - unable to parse first word of record '$trimrec' id:$DEF_definition_id"
} }
set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict #set record_values [lassign $trimrec firstword]
if {[llength $record_values] % 2 != 0} { if {[llength $record_values] % 2 != 0} {
#todo - avoid raising an error - store invalid defs keyed on id #todo - avoid raising an error - store invalid defs keyed on id
error "punk::args::resolve - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" error "punk::args::resolve - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id"
@ -1808,6 +1832,14 @@ tcl::namespace::eval punk::args {
#set opt_any $v #set opt_any $v
tcl::dict::set F $fid OPT_ANY $v tcl::dict::set F $fid OPT_ANY $v
} }
-mash {
#default for single letter options that can be mashed together - e.g -a -b can be supplied as -ab if -mash is 1
#check is bool
if {![string is boolean -strict $v]} {
error "punk::args::resolve - Option '$k' has value '$v'of wrong type in @opts line. Must be boolean @id:$DEF_definition_id"
}
tcl::dict::set tmp_optspec_defaults $k $v
}
-min { -min {
dict set F $fid OPT_MIN $v dict set F $fid OPT_MIN $v
} }
@ -1918,7 +1950,7 @@ tcl::namespace::eval punk::args {
} }
default { default {
set known { -parsekey -group -grouphelp\ set known { -parsekey -group -grouphelp\
-any -anyopts -arbitrary -form -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo\ -any -anyopts -mash -arbitrary -form -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo\
-type -range -typeranges -default -defaultdisplaytype -typedefaults -type -range -typeranges -default -defaultdisplaytype -typedefaults
-choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted -nocase\ -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted -nocase\
-unindentedfields\ -unindentedfields\
@ -2402,6 +2434,8 @@ tcl::namespace::eval punk::args {
foreach fid $record_form_ids { foreach fid $record_form_ids {
if {$is_opt} { if {$is_opt} {
#OPTSPEC_DEFAULTS are the base defaults for options - these can be overridden by @opts lines
#we may still need to test some of these defaults for validity, e.g -mash true can only apply if the argname has at least one single-character alias (e.g -x or -x|--xxx)
set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS] set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS]
} else { } else {
if {[dict get $F $fid argspace] eq "values"} { if {[dict get $F $fid argspace] eq "values"} {
@ -2518,6 +2552,25 @@ tcl::namespace::eval punk::args {
-parsekey - -group { -parsekey - -group {
tcl::dict::set spec_merged -typesynopsis $specval tcl::dict::set spec_merged -typesynopsis $specval
} }
-mash {
#allow when any alt in argname is a single letter flag such s -a or -Z
#single letter flags do not have to be -type none to allow -mash to be set true.
#a mash can be supplied where the last flag in the mash is a value-taking flag.
if {$specval} {
set has_single_letter_flag 0
foreach alias $optaliases {
if {[string length $alias] == 2 && [string match -* $alias]} {
set has_single_letter_flag 1
break
}
}
if {!$has_single_letter_flag} {
error "punk::args::resolve - invalid use of -mash for argument '$argname'. -mash can only be true if at least one alias in the argname is a single-letter flag (e.g -a or -Z) @id:$DEF_definition_id"
#todo - we also have to set -mash false when processing defaults from @opts if the argname doesn't contain any single-letter flags
}
}
tcl::dict::set spec_merged -mash $specval
}
-unindentedfields - -unindentedfields -
-solo - -solo -
-choices - -choicegroups - -choicemultiple - -choicecolumns - -choices - -choicegroups - -choicemultiple - -choicecolumns -
@ -2661,6 +2714,30 @@ tcl::namespace::eval punk::args {
if {[tcl::dict::get $spec_merged -type] eq "none"} { if {[tcl::dict::get $spec_merged -type] eq "none"} {
dict set F $fid OPT_SOLOS [list {*}[dict get $F $fid OPT_SOLOS] $argname] dict set F $fid OPT_SOLOS [list {*}[dict get $F $fid OPT_SOLOS] $argname]
} }
if {[tcl::dict::get $spec_merged -mash]} {
#The value for -mash might be true only due to a default from @opts - in which case we need to check the argname for validity of -mash as described above and if not valid, set -mash false in the ARG_INFO for this argname
if {$argname eq "--"} {
#force -mash false - in case no -mash was specified on the flag itself and @opts -mash is true
tcl::dict::set spec_merged -mash false
} else {
set has_single_letter_flag 0
foreach alias $optaliases {
if {[string length $alias] == 2 && [string match -* $alias]} {
set has_single_letter_flag 1
break
}
}
if {!$has_single_letter_flag} {
#force -mash false in ARG_INFO for this argname - in case no -mash was specified and @opts -mash is true by default but argname doesn't contain any single-letter flags
tcl::dict::set spec_merged -mash false
}
}
#re-test state of -mash after any adjustments based on argname validity and defaults
if {[tcl::dict::get $spec_merged -mash]} {
#we add the whole argname with all aliases to the OPT_MASHES list - this is used during parsing to check if any of the aliases for a given flag are mashable
dict set F $fid OPT_MASHES [list {*}[dict get $F $fid OPT_MASHES] $argname]
}
}
} else { } else {
tcl::dict::set F $fid ARG_CHECKS $argname\ tcl::dict::set F $fid ARG_CHECKS $argname\
[tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi -choicecolumns -group -typesynopsis -help -ARGTYPE] ;#leave things like -range -minsize [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi -choicecolumns -group -typesynopsis -help -ARGTYPE] ;#leave things like -range -minsize
@ -2716,6 +2793,21 @@ tcl::namespace::eval punk::args {
#now cycle through ALL forms not just form_ids_active (record_form_ids) #now cycle through ALL forms not just form_ids_active (record_form_ids)
dict for {fid formdata} $F { dict for {fid formdata} $F {
set mashargs [dict get $F $fid OPT_MASHES]
if {[llength $mashargs]} {
#precalculate OPT_ALL_MASH_LETTERS
set all_mash_letters [list]
foreach fullopt $mashargs {
foreach flagpart [split $fullopt |] {
if {[string length $flagpart] == 2 && [string match -* $flagpart]} {
lappend all_mash_letters [string index $flagpart 1]
}
}
}
dict set F $fid OPT_ALL_MASH_LETTERS $all_mash_letters
}
if {[tcl::dict::get $F $fid OPT_MAX] eq ""} { if {[tcl::dict::get $F $fid OPT_MAX] eq ""} {
if {[llength [tcl::dict::get $F $fid OPT_NAMES]] == 0 && ![tcl::dict::get $F $fid OPT_ANY]} { if {[llength [tcl::dict::get $F $fid OPT_NAMES]] == 0 && ![tcl::dict::get $F $fid OPT_ANY]} {
tcl::dict::set F $fid OPT_MAX 0 ;#aid in parsing to avoid scanning for opts unnecessarily tcl::dict::set F $fid OPT_MAX 0 ;#aid in parsing to avoid scanning for opts unnecessarily
@ -3292,8 +3384,8 @@ tcl::namespace::eval punk::args {
return true return true
} }
foreach d $rawdef { foreach d $rawdef {
if {[regexp {\s*(\S+)} $d _match firstword]} { if {[regexp {\s*(\S+)} $d _match first_rawdef_word]} {
if {$firstword eq "@dynamic"} { if {$first_rawdef_word eq "@dynamic"} {
return true return true
} }
} }
@ -3513,7 +3605,7 @@ tcl::namespace::eval punk::args {
} }
# -- --- --- --- --- --- # -- --- --- --- --- ---
set unscanned [punklib_ldiff $registered $scanned_packages] set unscanned [punk::args::system::punklib_ldiff $registered $scanned_packages]
if {[llength $unscanned]} { if {[llength $unscanned]} {
foreach pkgns $unscanned { foreach pkgns $unscanned {
set idcount 0 set idcount 0
@ -3562,7 +3654,7 @@ tcl::namespace::eval punk::args {
if {"*" in $nslist} { if {"*" in $nslist} {
set needed [punklib_ldiff $registered $loaded_packages] set needed [punk::args::system::punklib_ldiff $registered $loaded_packages]
} else { } else {
set needed [list] set needed [list]
foreach pkgns $nslist { foreach pkgns $nslist {
@ -4311,6 +4403,33 @@ tcl::namespace::eval punk::args {
set trie [punk::trie::trieclass new {*}$all_opts --] set trie [punk::trie::trieclass new {*}$all_opts --]
set idents [dict get [$trie shortest_idents ""] scanned] set idents [dict get [$trie shortest_idents ""] scanned]
if {[llength [dict get $form_dict OPT_MASHES]]} {
set all_mash_letters [dict get $form_dict OPT_ALL_MASH_LETTERS]
#now extend idents to be at least as long as the number of mash/bundle flags that exist.
#(when the flag itself is longer than number of mash flags
# - e.g for flags -x -v -c -f -collection, the ident for -collection would be -co normally
# but if we have 4 mash flags, we want it to be -colle to satisfy the requirement that it is longer then the number of mash flags
# unless it is an exact match.)
#
#e.g if all the single letter flags are configured with -mash true:
#our prefix calculation might give us the following idents:
# idents: -cabinet -ca -a -a -b -b -c -c -- --
#we need only to extend -cabinet to -cabi to satisfy the requirement that it is longer than the number of mash flags (3 in this example because -- is never a mash flag)
dict for {fullname ident} $idents {
set mashcount [llength $all_mash_letters]
#assert: if we are here - mashcount > 0
if {[string length $ident] < [string length $fullname] && [string length $ident] <= $mashcount} {
dict set idents $fullname [string range $fullname 0 $mashcount+1]
}
}
#note it's still possible for the user to define a flag with a name shorter than the number of mash flags
# and it could even overlap with a specific combination of mash letters - e.g -a -b -c -d and a flag named -bac
# - in this case a provided value of -bac would still match the flag -bac rather than being treated as a mash of -b -a -c
#because the exact match will take priority over the prefix match.
#Whilst this configuration is accepted - it's not recommended.
}
#todo - check opt_prefixdeny #todo - check opt_prefixdeny
$trie destroy $trie destroy
@ -7906,6 +8025,8 @@ tcl::namespace::eval punk::args {
#set OPT_MIN [dict get $formdict OPT_MIN] #set OPT_MIN [dict get $formdict OPT_MIN]
set OPT_MAX [dict get $formdict OPT_MAX] set OPT_MAX [dict get $formdict OPT_MAX]
#set OPT_SOLOS [dict get $formdict OPT_SOLOS] #set OPT_SOLOS [dict get $formdict OPT_SOLOS]
set OPT_MASHES [dict get $formdict OPT_MASHES]
set OPT_ALL_MASH_LETTERS [dict get $formdict OPT_ALL_MASH_LETTERS]
set OPTSPEC_DEFAULTS [dict get $formdict OPTSPEC_DEFAULTS] set OPTSPEC_DEFAULTS [dict get $formdict OPTSPEC_DEFAULTS]
set OPT_CHECKS_DEFAULTS [dict get $formdict OPT_CHECKS_DEFAULTS] set OPT_CHECKS_DEFAULTS [dict get $formdict OPT_CHECKS_DEFAULTS]
#set OPT_GROUPS [dict get $formdict OPT_GROUPS] #set OPT_GROUPS [dict get $formdict OPT_GROUPS]
@ -7956,8 +8077,11 @@ tcl::namespace::eval punk::args {
} }
} }
} }
#note all_opts will necessarily not include mashed flags (e.g -abc) when only -a -b -c are defined - but we will detect and break those down in the main loop below
set all_opts [dict keys $lookup_optset] set all_opts [dict keys $lookup_optset]
set ridx 0 set ridx 0
set rawargs_copy $rawargs set rawargs_copy $rawargs
set remaining_rawargs $rawargs set remaining_rawargs $rawargs
@ -8374,15 +8498,225 @@ tcl::namespace::eval punk::args {
#flagsupplied when --longopt=x is --longopt (may still be a prefix) #flagsupplied when --longopt=x is --longopt (may still be a prefix)
#get full flagname from possible prefix $flagsupplied #get full flagname from possible prefix $flagsupplied
set flagname [tcl::prefix match -error "" [list {*}$all_opts --] $flagsupplied] set flagname [tcl::prefix match -error "" [list {*}$all_opts --] $flagsupplied]
if {$flagname eq "--"} { #The prefix matching above doesn't consider that mashed flags can make shorter prefixes an invalid match for the whole flag.
set optionset "" #if the length of our matched flagname is less than the length of $OPT_ALL_MASH_LETTERS, then we may have a mash of other flags,
} else { #not a valid match for some longer flag that just happens to share the same prefix as the start of the mash.
if {[dict exists $lookup_optset $flagname]} { #we have defined valid prefix matches in the presence of mashed flags to be only those that are longer than any possible mash of flags
set optionset [dict get $lookup_optset $flagname]
} else { #(review - for small numbers of mashed flags we could be more precise, but the combinatoric explosion of longer mash lengths makes it
#simpler to just say any match that is shorter than the length of the longest possible mash is invalid
# we may need consider what common utilities do in practice regarding allowing prefixes in the presence of mashed flags
#- but it seems likely that they would either not allow prefixes at all, or only allow prefixes that are longer than any possible mash of flags)
#So if we have a match that isn't exact and is shorter than the length of the longest possible mash, we need to check if it's actually a mash of valid flags rather than a valid prefix match for a longer flag.
if {$flagname ne $flagsupplied && [llength $OPT_MASHES] && (([string length $flagsupplied] -1) <= [llength $OPT_ALL_MASH_LETTERS])} {
#invalidate the match
set flagname ""
}
switch -- $flagname {
-- {
set optionset "" set optionset ""
} }
"" {
#no match for flagname - could be a mashed flag e.g -abc where only -a -b -c are defined
if {![llength $OPT_MASHES]} {
#no mashed flags defined - so this probably isn't a flag - could be a value
set optionset ""
} else {
#check if every letter after the first matches a defined opt - if so treat as mashed flags
set mashflags [string range $flagsupplied 1 end]
set mashletters [split $mashflags ""]
set all_mashable true
foreach mf $mashletters {
if {$mf ni $OPT_ALL_MASH_LETTERS} {
set all_mashable false
break
}
}
#todo - move block below up here.
if {!$all_mashable} {
puts stderr "Debug: flagsupplied '$flagsupplied' not a valid flagname and not a valid mash of flags - treating as value"
#- probably isn't a flag at all - could be a value
#treat as value
set optionset ""
} else {
#puts stderr "Debug: flagsupplied '$flagsupplied' not a valid flagname but is a valid mash of flags - treating as mash of flags"
#treat as mashed flags - we will break down into individual flags and process each one in turn
set optionset $flagsupplied
#the -mash option means we may have to process multiple flags as received for one arg that looks like a flag
#we can still use the lookup_optset dict to get the optionset for each individual flag - as the keys of lookup_optset are all the individual flags (not mashed together)
#we need to update:
# vals_remaining_possible after processing all matchletters (by -1 or -2 depending on whether the mash includes a flag with an attached value (trailing=<val>) or accepts a value.)
# multisreceived
# soloreceived (if any of the flags in the mash are solo)
# flagsreceived (add the mash as received - but also add each individual flag in the mash as received for the purposes of checking for multiple and solo)
# opts (for each flag in the mash)
set posn 0
set consume_value 0 ;#if last mash flag accepts a value, we will consume the next arg as its value
foreach mf $mashletters {
set matchopt [dict get $lookup_optset -$mf]
if {$matchopt eq ""} {
#this should not happen as we have already checked all letters are mashable - but check just in case
puts stderr "Debug: mash letter '-$mf' not in lookup_optset - this should not happen"
} else {
#process each mashed flag as if it were received separately
#- we can reuse the same flagval for each as they won't be expected to have values (as they are single letter flags)
#we will still need to check for multiple and defaults for each individual flag
#we can also still use the same argstate entries for each individual flag as the optionset will be the same for each of the mashed flags (as they will all be defined in the same optionset e.g -a|-b|-c)
set mashflagname -$mf
set mashflagoptionset [dict get $lookup_optset $mashflagname]
set raw_optionset_members [split $mashflagoptionset |]
#set mashflagapiopt [dict get $argstate $mashflagoptionset -parsekey]
#if {$mashflagapiopt eq ""} {
# set mashflagapiopt [string trimright [lindex [split $mashflagoptionset |] end] =]
#}
set flagname -$mf
if {[tcl::dict::get $argstate $mashflagoptionset -parsekey] ne ""} {
set api_opt [dict get $argstate $mashflagoptionset -parsekey]
} else {
set api_opt [string trimright [lindex $raw_optionset_members end] =]
}
if {$api_opt eq $flagname} {
set flag_ident $api_opt
set flag_ident_is_parsekey 0
} else {
#initially key our opts on a long form allowing us to know which specific flag was used
#(for when multiple map to same parsekey e.g lsearch)
#e.g -increasing|-SORTOPTION
set flag_ident $flagname|$api_opt
set flag_ident_is_parsekey 1
}
set optionset_type [tcl::dict::get $argstate $mashflagoptionset -type]
#only the last flag in a mash can be allowed to have a value, and the other flags must be of type none.
#flags are by default optional.
if {$optionset_type ne "none"} {
#A flag with a value - only allowed for the last flag in a mash
if {$posn != [expr {[llength $mashletters] - 1}]} {
#not the last flag in the mash - can't have a value
set errmsg "bad options for %caller%. Flag \"$mashflagname\" in mash \"$flagsupplied\" cannot have a value as only the last flag in a mash can have a value. The flag \"$mashflagname\" must be of type none. (1)"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $all_opts] -badarg $a -argspecs $argspecs]] $errmsg
} else {
set consume_value 1
# ------------
#check if it was actually a value that looked like a flag
if {$i == $maxidx} {
#if no optvalue following - assume it's a value
#(caller should probably have used -- before it)
#review
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
break
}
#flagval comes from next remaining rawarg
set flagval [lindex $remaining_rawargs $i+1]
if {[tcl::dict::get $argstate $mashflagoptionset -multiple]} {
#don't lappend to default - we need to replace if there is a default
if {$api_opt ni $flagsreceived} {
tcl::dict::set opts $flag_ident [list $flagval]
} else {
tcl::dict::lappend opts $flag_ident $flagval
}
if {$api_opt ni $multisreceived} {
lappend multisreceived $api_opt
}
} else {
#tcl::dict::set opts $flag_ident $flagval
if {$flag_ident_is_parsekey} {
#necessary shimmer ?
lappend opts $flag_ident $flagval
} else {
tcl::dict::set opts $flag_ident $flagval
}
}
#incr i to skip flagval
#incr vals_remaining_possible -2
#if {[incr i] > $maxidx} {
# set msg "Bad options for %caller%. No value supplied for last option $mashflagoptionset at index [expr {$i-1}] which is not marked with -type none"
# return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $mashflagoptionset index [expr {$i-1}]] -badarg $mashflagoptionset -argspecs $argspecs]] $msg
#}
# ------------
}
} else {
#flag with no value - check for -typedefaults for the flag
#none / solo
if {[tcl::dict::exists $argstate $mashflagoptionset -typedefaults]} {
set tdflt [tcl::dict::get $argstate $mashflagoptionset -typedefaults]
} else {
#normal default for a solo is 1 unless overridden by -typedefaults
set tdflt 1
}
if {[tcl::dict::get $argstate $mashflagoptionset -multiple]} {
#puts stderr "Debug: flag '$mashflagname' in mash '$flagsupplied' is a multiple with typedefaults $tdflt -- api_opt: $api_opt flag_ident: $flag_ident flagsreceived: $flagsreceived multisreceived: $multisreceived"
if {$api_opt ni $flagsreceived} {
#override any default - don't lappend to it
tcl::dict::set opts $flag_ident $tdflt
} else {
tcl::dict::lappend opts $flag_ident $tdflt
}
if {$api_opt ni $multisreceived} {
lappend multisreceived $api_opt
}
} else {
#test parse_withdef_parsekey_repeat_ordering {Ensure last flag has precedence}
#tcl::dict::set opts $flag_ident $tdflt
if {$flag_ident_is_parsekey} {
#(shimmer - but required for ordering correctness during override)
puts stderr "Debug: flag '$mashflagname' in mash '$flagsupplied' flag_ident '$flag_ident' is the same as parsekey '$api_opt' tdflt: $tdflt - using lappend to ensure it ends up after any previous flag in the mash that had the same parsekey"
lappend opts $flag_ident $tdflt
puts stderr "opts after lappend: $opts"
} else {
tcl::dict::set opts $flag_ident $tdflt
}
}
#incr vals_remaining_possible -1
lappend solosreceived $api_opt ;#dups ok
}
}
lappend flagsreceived $api_opt
incr posn
}
#update vals_remaining_possible by one or 2 if the last flag took a value.
incr vals_remaining_possible -1
if {$flagval_included || $consume_value} {
incr vals_remaining_possible -1
}
#after processing the mash, we will have updated opts for each individual flag in the mash,
#and updated multisreceived and solo_received as needed based on the optionset entries for each individual flag in the mash
#we possibly need to incr i to skip a received value for the mash if the last flag in the mash had a value.
#or break if we have reached the end of the args after processing the mash
if {$flagval_included || $consume_value} {
#the last flag in the mash had a value - we have already processed it for that flag - so we need to skip it for the next iteration of the loop
incr i
if {$i > $maxidx} {
#we have reached the end of the args after processing the mash and its value - so we can break out of the loop
break
}
} else {
#no value included for the last flag in the mash - so we just continue to the next iteration of the loop to process the next arg
}
continue
}
}
}
default {
if {[dict exists $lookup_optset $flagname]} {
set optionset [dict get $lookup_optset $flagname]
} else {
#we matched a prefix of all_opts - but it's not in the lookup_optset?
#review - this should not happen as we only match prefixes from all_opts which is derived from the keys of lookup_optset
puts stderr "Debug: matched prefix '$flagname' not in lookup_optset - this should not happen"
set optionset ""
}
}
} }
if {$optionset ne ""} { if {$optionset ne ""} {
#matched some option - either in part or in full. #matched some option - either in part or in full.
set raw_optionset_members [split $optionset |] set raw_optionset_members [split $optionset |]
@ -9205,7 +9539,7 @@ tcl::namespace::eval punk::args {
#} #}
#for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us
if {[llength $LEADER_REQUIRED]} { if {[llength $LEADER_REQUIRED]} {
if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { if {[llength [set missing [punk::args::system::punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} {
set msg "Required leader missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" 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 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 #arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs
@ -9213,7 +9547,7 @@ tcl::namespace::eval punk::args {
} }
if {[llength $OPT_REQUIRED]} { if {[llength $OPT_REQUIRED]} {
set api_opt_required [lmap v $OPT_REQUIRED {lindex [split $v |] end}] set api_opt_required [lmap v $OPT_REQUIRED {lindex [split $v |] end}]
if {[llength [set missing [punklib_ldiff $api_opt_required $flagsreceived]]]} { if {[llength [set missing [punk::args::system::punklib_ldiff $api_opt_required $flagsreceived]]]} {
set full_missing [list] set full_missing [list]
foreach m $missing { foreach m $missing {
lappend full_missing [dict get $lookup_optset $m] lappend full_missing [dict get $lookup_optset $m]
@ -9225,7 +9559,7 @@ tcl::namespace::eval punk::args {
} }
} }
if {[llength $VAL_REQUIRED]} { if {[llength $VAL_REQUIRED]} {
if {[llength [set missing [punklib_ldiff $VAL_REQUIRED $valnames_received]]]} { if {[llength [set missing [punk::args::system::punklib_ldiff $VAL_REQUIRED $valnames_received]]]} {
set msg "Required value missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" 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 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 #arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs
@ -10026,8 +10360,8 @@ tcl::namespace::eval punk::args {
set alternates [list];#alternate acceptable types e.g literal(yes)|literal(ok) or indexpression|literal(first) set alternates [list];#alternate acceptable types e.g literal(yes)|literal(ok) or indexpression|literal(first)
set type_alternatives [_split_type_expression $tp] set type_alternatives [_split_type_expression $tp]
foreach tp_alternative $type_alternatives { foreach tp_alternative $type_alternatives {
set firstword [lindex $tp_alternative 0] set tp_alternative_word1 [lindex $tp_alternative 0]
switch -exact -- $firstword { switch -exact -- $tp_alternative_word1 {
literal { literal {
set match [lindex $tp_alternative 1] set match [lindex $tp_alternative 1]
lappend alternates $match lappend alternates $match
@ -11485,7 +11819,7 @@ tcl::namespace::eval punk::args::package {
-return\ -return\
-type string\ -type string\
-default table\ -default table\
-choices {string table tableobject}\ -choices {string table tableobject dict}\
-choicelabels { -choicelabels {
string\ string\
"A basic text layout" "A basic text layout"
@ -11564,19 +11898,25 @@ tcl::namespace::eval punk::args::package {
} }
} }
} }
if {$opt_return ne "string"} {
package require textblock ;#table support
set is_table 1
set title [string cat {[} $pkgname {]} ]
set t [textblock::class::table new -title $title]
$t configure -frametype double -minwidth [expr {[string length $title]+2}]
} else { set is_table 0
set topiclens [lmap t $topics {string length $t}] switch -- $opt_return {
set widest_topic [tcl::mathfunc::max {*}$topiclens] table - tableobject {
set is_table 0 package require textblock ;#table support
set about "$pkgname\n" set is_table 1
append about [string repeat - $widest_topic] \n set title [string cat {[} $pkgname {]} ]
set t [textblock::class::table new -title $title]
$t configure -frametype double -minwidth [expr {[string length $title]+2}]
}
string {
set topiclens [lmap t $topics {string length $t}]
set widest_topic [tcl::mathfunc::max {*}$topiclens]
set about "$pkgname\n"
append about [string repeat - $widest_topic] \n
}
dict {
set about [dict create]
}
} }
foreach topic $topics { foreach topic $topics {
if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} {
@ -11584,14 +11924,20 @@ tcl::namespace::eval punk::args::package {
} else { } else {
set topic_contents "<unavailable>" set topic_contents "<unavailable>"
} }
if {!$is_table} { switch -- $opt_return {
set content_lines [split $topic_contents \n] table - tableobject {
append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n $t add_row [list $topic $topic_contents]
foreach ln [lrange $content_lines 1 end] { }
append about [format %-${widest_topic}s ""] " " $ln \n string {
set content_lines [split $topic_contents \n]
append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n
foreach ln [lrange $content_lines 1 end] {
append about [format %-${widest_topic}s ""] " " $ln \n
}
}
dict {
dict set about $topic $topic_contents
} }
} else {
$t add_row [list $topic $topic_contents]
} }
} }
@ -11662,6 +12008,121 @@ tcl::namespace::eval punk::args::system {
} }
# == === === === === === === === === === === === === === ===
# Sample 'about' function with punk::args documentation
# == === === === === === === === === === === === === === ===
tcl::namespace::eval punk::args {
namespace eval argdoc {
#namespace for custom argument documentation
namespace import ::punk::args::helpers::*
proc package_name {} {
return punk::args
}
proc about_topics {} {
#info commands results are returned in an arbitrary order (like array keys)
set topic_funs [info commands [namespace current]::get_topic_*]
set about_topics [list]
foreach f $topic_funs {
set tail [namespace tail $f]
lappend about_topics [string range $tail [string length get_topic_] end]
}
#Adjust this function or 'default_topics' if a different order is required
return [lsort $about_topics]
}
proc default_topics {} {return [list Description *]}
# -------------------------------------------------------------
# get_topic_ functions add more to auto-include in about topics
# -------------------------------------------------------------
proc get_topic_Description {} {
punk::args::lib::tstr -indent " " [string trim {
package punk::args
Argument parsing library for Tcl.
Can be used purely for documentation of arguments and options, or also for actual argument parsing in procs.
supports longopts-style options, subcommands, and generation of help text.
"mash options" aka "short option bundling" or "flag/option stacking"
punk::args supports mash options for single letter flags that don't take arguments, e.g -a -b -c -> -abc or -bac etc
The last option in a mash can take an argument, e.g -x -v -f <filename> -> -xvf <filename>
Note the number of permutations of options with mashing can get large quickly.
(e.g 10 flags would have 10! = 3,628,800 permutations if all could be mashed together)
This has implications if we also support unique abbreviations of options as every permutation of the mashing
would need to be checked for conflicts with other options and their abbreviations.
The chosen solution is to determine the longest possible mashes for a given set of options, and then require
any abbreviations of other -options to be longer than the longest mash, so that there is no ambiguity between
an abbreviation and a mash.
E.g if we have -mash true and the options -a -b -c -d -backwards -cabinet -call, then the longest mash/bundle is 4 chars
(-abcd -bacd etc), so using the longest mash/bundle length of 4, we require that any abbreviation of other options must be at
least 5 chars long.
In this case -backwards could be abbreviated to -backw or -backwa etc, but not to -ba, -bac or -back.
As an exact match; -call would be accepted.
Whilst in this specific case -back is theoretically unambiguous - we still stick to the rule of requiring abbreviations to be
longer than the longest mash, to keep the rules simple and consistent; and so easier to process and to predict and reason about.
Although the combinations of -a -b -c -d are manageable in this case, if we had more single-letter options we would
not want to use a huge number of combinations of mashes to calculate the allowable prefix matches.
we calculate prefixes based on the flag names as usual, but extend the required prefixes of options such as -cabinet to be longer
(-cab extended to -cabin, -cal extended to -call).
} \n]
}
proc get_topic_License {} {
return " BSD 3-Clause"
}
proc get_topic_Version {} {
return " $::punk::args::version"
}
proc get_topic_Contributors {} {
set authors {{Julian Noble <julian@precisium.com.au>}}
set contributors ""
foreach a $authors {
append contributors $a \n
}
if {[string index $contributors end] eq "\n"} {
set contributors [string range $contributors 0 end-1]
}
return [punk::lib::tstr -indent " " $contributors]
}
proc get_topic_notes {} {
punk::args::lib::tstr -indent " " -return string {
see output of:
punk::args::usage ::punk::args::parse
As a convenience in a shell with the various punk packages loaded, you can also do:
i punk::args::parse
Here i is an alias for punk::ns::cmdhelp which allows lookup of unqualified command names
based on the current context.
}
}
# -------------------------------------------------------------
}
# we re-use the argument definition from punk::args::standard_about and override some items
set overrides [dict create]
dict set overrides @id -id "::punk::args::about"
dict set overrides @cmd -name "punk::args::about"
dict set overrides @cmd -help [string trim [punk::args::lib::tstr {
About punk::args
}] \n]
dict set overrides topic -choices [list {*}[punk::args::argdoc::about_topics] *]
dict set overrides topic -choicerestricted 1
dict set overrides topic -default [punk::args::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *]
lappend PUNKARGS [list $newdef]
proc about {args} {
package require punk::args
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on
set argd [punk::args::parse $args withid ::punk::args::about]
lassign [dict values $argd] _leaders opts values _received
punk::args::package::standard_about -package_about_namespace ::punk::args::argdoc {*}$opts {*}[dict get $values topic]
}
}
# end of sample 'about' function
# == === === === === === === === === === === === === === ===
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready ## Ready

2
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm

@ -3315,7 +3315,7 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
Each element except ${$B}type${$N} is a decimal string with the value of the corresponding field from the Each element except ${$B}type${$N} is a decimal string with the value of the corresponding field from the
stat return structure; see the manual entry for stat for details on the meanings of the values. stat return structure; see the manual entry for stat for details on the meanings of the values.
The type element gives the type of the file in the same form returned by the command ${$B}file type${$N}." The type element gives the type of the file in the same form returned by the command ${$B}file type${$N}."
@values -min 1 -max 1 @values -min 1 -max 2
name -optional 0 -type string name -optional 0 -type string
varName -type string -optional 1 varName -type string -optional 1
} "@doc -name Manpage: -url [manpage_tcl file]"] } "@doc -name Manpage: -url [manpage_tcl file]"]

19
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/ns-0.1.0.tm

@ -54,12 +54,19 @@ tcl::namespace::eval punk::nav::ns {
n// p* - list namespaces below current and commands in current matching p* n// p* - list namespaces below current and commands in current matching p*
} }
@values -min 1 -max -1 -type string @values -min 1 -max -1 -type string
v -type string -choices {/ //} -help\ v -type string\
" -choices {/ // ///}\
/ - list namespaces only -choicelabels {
// - list namespaces and commands /\
/// - list namespaces, commands and commands resolvable via 'namespace path' "list namespaces only"
" //\
"list namespaces and commands"
///\
"list namespaces, commands and commands
resolvable via 'namespace path'"
}\
-help\
"The form of navigation/listing to perform."
nsglob -type string -optional true -multiple true -help\ nsglob -type string -optional true -multiple true -help\
"A glob pattern supporting placeholders * and ?, to filter results. "A glob pattern supporting placeholders * and ?, to filter results.
If multiple patterns are supplied, then a listing for each pattern is returned. If multiple patterns are supplied, then a listing for each pattern is returned.

148
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm

@ -85,25 +85,40 @@ namespace eval punk::repo {
set allcmds [runout -n fossil help -a] set allcmds [runout -n fossil help -a]
set mainhelp [runout -n fossil help] set mainhelp [runout -n fossil help]
set maincommands [list] set maincommands [list]
#only start parsing for TOPICS after a line such as "Other comman values for TOPIC:"
set parsing_topics 0
foreach ln [split $mainhelp \n] { foreach ln [split $mainhelp \n] {
set ln [string trim $ln] set ln [string trim $ln]
if {$ln eq "" || [regexp {^[A-Z]+} $ln]} { if {$ln eq ""} {
continue continue
} }
lappend maincommands {*}$ln if {[string match "*values for TOPIC*" $ln]} {
set parsing_topics 1
continue
}
if {$parsing_topics} {
#lines starting with uppercase are topic headers - we want to ignore these and any blank lines
if {[regexp {^[A-Z]+} $ln]} {
continue
}
lappend maincommands {*}$ln
}
} }
#fossil output was ordered in columns, but we loaded list in row-wise, messing up the order #fossil output was ordered in columns, but we loaded list in row-wise, messing up the order
set maincommands [lsort $maincommands] set maincommands [lsort $maincommands]
set allcmds [lsort $allcmds] set allcmds [lsort $allcmds]
set othercmds [punk::lib::ldiff $allcmds $maincommands] set othercmds [punk::lib::ldiff $allcmds $maincommands]
set fossil_setting_names [lsort [runout -n fossil help -s]]
set result "@leaders -min 0\n" set result "@leaders -min 0\n"
append result [tstr -return string { append result [tstr -return string {
subcommand -type string -choicecolumns 8 -choicegroups { subcommand -type string -choicecolumns 8 -choicegroups {
"frequently used commands" {${$maincommands}} "frequently used commands" {${$maincommands}}
"" {${$othercmds}} "" {${$othercmds}}
} -choiceinfo {add {{doctype punkargs}} diff {{doctype punkargs}}} } -choiceprefixreservelist {${$fossil_setting_names}} -choiceinfo {add {{doctype punkargs}} diff {{doctype punkargs}}}
}] }]
#-choiceinfo { #-choiceinfo {
# add {{doctype punkargs}} # add {{doctype punkargs}}
@ -132,20 +147,127 @@ namespace eval punk::repo {
#experiment #experiment
lappend PUNKARGS [list {
@dynamic proc get_fossil_subcommand_usage {subcmd} {
@id -id "::punk::repo::fossil_proxy diff" set result ""
@cmd -name "fossil diff" -help "fossil diff" append result "@leaders -min 0 -max 0\n"
@formdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}} append result "@opts\n"
} ""] #The -o output sometimes includes portions of the general help text that happens to describe options.
#e.g fossil help diff -o includes
# "--webpage -y HTML output in the side-by-side format"
#as well as:
#" --webpage Format output as a stand-alone HTML webpage"
# we also get duplicates for --tk --by -b -y
#this suggests -o just does a basic parsing of the usage text and pulls out anything that looks like an option.
#other commands such as: fossil help fdiff -o
# return no options - but the help text states that fdiff accepts the same options as diff.
set basic_opt_lines [split [runout -n fossil help $subcmd -o] \n]
set help_lines [split [runout -n fossil help $subcmd] \n]
#first set of lines are for Usage:
#e.g
# % fossil help diff
# Usage: fossil diff|gdiff ?OPTIONS? FILE1 ?FILE2 ...?
# % fossil help ls
# Usage: fossil ls ?OPTIONS? ?PATHS ...?
#When there are multiple forms of usage we may get some "or:" lines.
#e.g
# % fossil help commit
# Usage: fossil commit ?OPTIONS? ?FILE...?
# or: fossil ci ?OPTIONS? ?FILE...?
# % fossil help mv
# Usage: fossil mv|rename ?OPTIONS? OLDNAME NEWNAME
# or: fossil mv|rename ?OPTIONS? OLDNAME... DIR
#(at least some "unsupported" test- commands don't provide a Usage line at all - e.g fossil help test-http)
foreach ln $basic_opt_lines {
set ln [string trim $ln]
if {$ln eq ""} {
continue
}
#the truncated description lines aren't useful here - but are always separated from the option info by more than one space.
set colbreak [string first " " $ln] ;#first occurrence of 2 spaces in a row - which is the separator between option info and description in fossil help output
set optinfo [string range $ln 0 $colbreak-1]
#this isn't the full help info for the option - but it's what we have available in the output of 'fossil help subcmd -o' - which is more concise and easier to parse than the full help for each option.
#todo - call fossil help <subcmd> and retrieve full help for each option.
set temphelp [string range $ln $colbreak end]
set opthelp [string trim $temphelp]
#we expect either one or two parts.
lassign $optinfo namepart typepart
#e.g --case-sensitive BOOL
#e.g -v|--verbose
#e.g -ci|--checkin VERSION (convert to -ci|--checkin=|--checkin -type VERSION)
if {$typepart ne ""} {
set optnames [split $namepart "|"]
#rebuild optnames as punkoptiondef string retaining dashes and pipes but adding in additional forms for longopts - e.g -ci|--checkin becomes -ci|--checkin=|--checkin
set punknames [list]
foreach n $optnames {
if {[string match --* $n]} {
#set n [list $n [string range $n 2 end]= [string range $n 2 end]]
lappend punknames $n ${n}=
} elseif {[string match -* $n]} {
lappend punknames $n
} else {
error "Unexpected option format: $n"
}
}
set typepart "-type $typepart"
} else {
#use as is if the flag doesn't have an argument - e.g -v|--verbose
set punknames $namepart
set typepart "-type none"
}
set punkoptiondef [join $punknames "|"]
append result [tstr -return string {
${$punkoptiondef} ${$typepart} -help {${$opthelp}}
}]
}
append result [tstr -return string {
@values -min 1 -max -1
file -type string -multiple 1 -help "file or directory to add to fossil"
}]
return $result
}
lappend PUNKARGS [list { lappend PUNKARGS [list {
#todo - remove this comment - testing dynamic directive #todo - remove this comment - testing dynamic directive
@dynamic @dynamic
@id -id "::punk::repo::fossil_proxy add" @id -id "::punk::repo::fossil_proxy add"
@cmd -name "fossil add" -help "fossil add @cmd -name "fossil add"\
" -summary\
""\
-help "fossil add"
@form -form "parsed"
${[punk::repo::get_fossil_subcommand_usage add]}
@form -form "raw" -synopsis "exec fossil add ?OPTIONS? FILE1 ?FILE2 ...?"
@formdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} @formdisplay -header "fossil help add" -body {${[runout -n fossil help add]}}
} ""] } ""]
lappend PUNKARGS [list {
@id -id "::punk::repo::fossil_proxy diff"
@cmd -name "fossil diff"\
-summary\
""\
-help\
"fossil diff"
@form -form "parsed"
${[punk::repo::get_fossil_subcommand_usage diff]}
@form -form "raw" -synopsis "exec fossil diff ?OPTIONS? FILE1 ?FILE2 ...?"
@formdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}}
} ""]
#TODO #TODO
#lappend PUNKARGS [list { #lappend PUNKARGS [list {
# @dynamic # @dynamic

537
src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm

@ -665,6 +665,8 @@ tcl::namespace::eval punk::args {
%B%@opts%N% ?opt val...? %B%@opts%N% ?opt val...?
directive-options: -any|-arbitrary <bool> directive-options: -any|-arbitrary <bool>
(also accepts options as defaults for subsequent flag definitions) (also accepts options as defaults for subsequent flag definitions)
e.g -mash 1 - default to single letter flags to be mashable/combinable
(-abc instead of -a -b -c)
%B%@values%N% ?opt val...? %B%@values%N% ?opt val...?
(used for trailing args that come after switches/opts) (used for trailing args that come after switches/opts)
directive-options: -min <int> -max <int> -unnamed <bool> directive-options: -min <int> -max <int> -unnamed <bool>
@ -813,6 +815,22 @@ tcl::namespace::eval punk::args {
Further unambiguous arrangements of optional args may be Further unambiguous arrangements of optional args may be
made in future - but are currently considered 'unsupported' made in future - but are currently considered 'unsupported'
-default <value> -default <value>
-mash <bool> (for flags/switches only)
Option clustering, flag stacking, option mashing
- all refer to the same thing:
Whether single letter flags can be mashed together.
E.g -abc instead of -a -b -c
This defaults to false, but can be set to true for all
single-letter flags by setting -mash true on the @opts directive.
It is an error to explicitly set -mash true on a flag that doesn't
have a single letter as part it's name.
(e.g it is ok on -f or even -f|--flag)
When such flags are combined, only the last one can take a value.
E.g with -mash true and flags -a -b and -c that take no values,
and -f that takes a value:
-abc is valid and equivalent to -a -b -c
-abcf <value> is valid and equivalent to -a -b -c -f <value>
but -afc <value> is not valid
-multiple <bool> (for leaders & values defines whether -multiple <bool> (for leaders & values defines whether
subsequent received values are stored against the same subsequent received values are stored against the same
argument name - only applies to final leader OR final value) argument name - only applies to final leader OR final value)
@ -1008,6 +1026,7 @@ tcl::namespace::eval punk::args {
-validate_ansistripped 0\ -validate_ansistripped 0\
-strip_ansi 0\ -strip_ansi 0\
-nocase 0\ -nocase 0\
-mash 0\
-choiceprefix 1\ -choiceprefix 1\
-choicerestricted 1\ -choicerestricted 1\
-choicemultiple {1 1}\ -choicemultiple {1 1}\
@ -1065,6 +1084,8 @@ tcl::namespace::eval punk::args {
OPT_MIN ""\ OPT_MIN ""\
OPT_MAX ""\ OPT_MAX ""\
OPT_SOLOS {}\ OPT_SOLOS {}\
OPT_MASHES {}\
OPT_ALL_MASH_LETTERS {}\
OPTSPEC_DEFAULTS $optdirective_defaults\ OPTSPEC_DEFAULTS $optdirective_defaults\
OPT_CHECKS_DEFAULTS {}\ OPT_CHECKS_DEFAULTS {}\
OPT_GROUPS {}\ OPT_GROUPS {}\
@ -1548,15 +1569,18 @@ tcl::namespace::eval punk::args {
"" - # {continue} "" - # {continue}
} }
incr record_number incr record_number
if {[catch {lassign $trimrec firstword}]} { #after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict
if {[catch {set record_values [lassign $trimrec firstword]}]} {
puts stdout "----------------------------------------------" puts stdout "----------------------------------------------"
puts stderr "rec: $rec" puts stderr "rec: $rec"
set ::testrecord $rec set ::testrecord $rec
puts stdout "----------------------------------------------" puts stdout "----------------------------------------------"
puts "records: $records" puts "records: $records"
puts stdout "==============================================" puts stdout "=============================================="
error "punk::args::resolve - bad optionspecs line - unable to parse first word of record '$trimrec' id:$DEF_definition_id"
} }
set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict #set record_values [lassign $trimrec firstword]
if {[llength $record_values] % 2 != 0} { if {[llength $record_values] % 2 != 0} {
#todo - avoid raising an error - store invalid defs keyed on id #todo - avoid raising an error - store invalid defs keyed on id
error "punk::args::resolve - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" error "punk::args::resolve - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id"
@ -1808,6 +1832,14 @@ tcl::namespace::eval punk::args {
#set opt_any $v #set opt_any $v
tcl::dict::set F $fid OPT_ANY $v tcl::dict::set F $fid OPT_ANY $v
} }
-mash {
#default for single letter options that can be mashed together - e.g -a -b can be supplied as -ab if -mash is 1
#check is bool
if {![string is boolean -strict $v]} {
error "punk::args::resolve - Option '$k' has value '$v'of wrong type in @opts line. Must be boolean @id:$DEF_definition_id"
}
tcl::dict::set tmp_optspec_defaults $k $v
}
-min { -min {
dict set F $fid OPT_MIN $v dict set F $fid OPT_MIN $v
} }
@ -1918,7 +1950,7 @@ tcl::namespace::eval punk::args {
} }
default { default {
set known { -parsekey -group -grouphelp\ set known { -parsekey -group -grouphelp\
-any -anyopts -arbitrary -form -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo\ -any -anyopts -mash -arbitrary -form -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo\
-type -range -typeranges -default -defaultdisplaytype -typedefaults -type -range -typeranges -default -defaultdisplaytype -typedefaults
-choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted -nocase\ -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted -nocase\
-unindentedfields\ -unindentedfields\
@ -2402,6 +2434,8 @@ tcl::namespace::eval punk::args {
foreach fid $record_form_ids { foreach fid $record_form_ids {
if {$is_opt} { if {$is_opt} {
#OPTSPEC_DEFAULTS are the base defaults for options - these can be overridden by @opts lines
#we may still need to test some of these defaults for validity, e.g -mash true can only apply if the argname has at least one single-character alias (e.g -x or -x|--xxx)
set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS] set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS]
} else { } else {
if {[dict get $F $fid argspace] eq "values"} { if {[dict get $F $fid argspace] eq "values"} {
@ -2518,6 +2552,25 @@ tcl::namespace::eval punk::args {
-parsekey - -group { -parsekey - -group {
tcl::dict::set spec_merged -typesynopsis $specval tcl::dict::set spec_merged -typesynopsis $specval
} }
-mash {
#allow when any alt in argname is a single letter flag such s -a or -Z
#single letter flags do not have to be -type none to allow -mash to be set true.
#a mash can be supplied where the last flag in the mash is a value-taking flag.
if {$specval} {
set has_single_letter_flag 0
foreach alias $optaliases {
if {[string length $alias] == 2 && [string match -* $alias]} {
set has_single_letter_flag 1
break
}
}
if {!$has_single_letter_flag} {
error "punk::args::resolve - invalid use of -mash for argument '$argname'. -mash can only be true if at least one alias in the argname is a single-letter flag (e.g -a or -Z) @id:$DEF_definition_id"
#todo - we also have to set -mash false when processing defaults from @opts if the argname doesn't contain any single-letter flags
}
}
tcl::dict::set spec_merged -mash $specval
}
-unindentedfields - -unindentedfields -
-solo - -solo -
-choices - -choicegroups - -choicemultiple - -choicecolumns - -choices - -choicegroups - -choicemultiple - -choicecolumns -
@ -2661,6 +2714,30 @@ tcl::namespace::eval punk::args {
if {[tcl::dict::get $spec_merged -type] eq "none"} { if {[tcl::dict::get $spec_merged -type] eq "none"} {
dict set F $fid OPT_SOLOS [list {*}[dict get $F $fid OPT_SOLOS] $argname] dict set F $fid OPT_SOLOS [list {*}[dict get $F $fid OPT_SOLOS] $argname]
} }
if {[tcl::dict::get $spec_merged -mash]} {
#The value for -mash might be true only due to a default from @opts - in which case we need to check the argname for validity of -mash as described above and if not valid, set -mash false in the ARG_INFO for this argname
if {$argname eq "--"} {
#force -mash false - in case no -mash was specified on the flag itself and @opts -mash is true
tcl::dict::set spec_merged -mash false
} else {
set has_single_letter_flag 0
foreach alias $optaliases {
if {[string length $alias] == 2 && [string match -* $alias]} {
set has_single_letter_flag 1
break
}
}
if {!$has_single_letter_flag} {
#force -mash false in ARG_INFO for this argname - in case no -mash was specified and @opts -mash is true by default but argname doesn't contain any single-letter flags
tcl::dict::set spec_merged -mash false
}
}
#re-test state of -mash after any adjustments based on argname validity and defaults
if {[tcl::dict::get $spec_merged -mash]} {
#we add the whole argname with all aliases to the OPT_MASHES list - this is used during parsing to check if any of the aliases for a given flag are mashable
dict set F $fid OPT_MASHES [list {*}[dict get $F $fid OPT_MASHES] $argname]
}
}
} else { } else {
tcl::dict::set F $fid ARG_CHECKS $argname\ tcl::dict::set F $fid ARG_CHECKS $argname\
[tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi -choicecolumns -group -typesynopsis -help -ARGTYPE] ;#leave things like -range -minsize [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi -choicecolumns -group -typesynopsis -help -ARGTYPE] ;#leave things like -range -minsize
@ -2716,6 +2793,21 @@ tcl::namespace::eval punk::args {
#now cycle through ALL forms not just form_ids_active (record_form_ids) #now cycle through ALL forms not just form_ids_active (record_form_ids)
dict for {fid formdata} $F { dict for {fid formdata} $F {
set mashargs [dict get $F $fid OPT_MASHES]
if {[llength $mashargs]} {
#precalculate OPT_ALL_MASH_LETTERS
set all_mash_letters [list]
foreach fullopt $mashargs {
foreach flagpart [split $fullopt |] {
if {[string length $flagpart] == 2 && [string match -* $flagpart]} {
lappend all_mash_letters [string index $flagpart 1]
}
}
}
dict set F $fid OPT_ALL_MASH_LETTERS $all_mash_letters
}
if {[tcl::dict::get $F $fid OPT_MAX] eq ""} { if {[tcl::dict::get $F $fid OPT_MAX] eq ""} {
if {[llength [tcl::dict::get $F $fid OPT_NAMES]] == 0 && ![tcl::dict::get $F $fid OPT_ANY]} { if {[llength [tcl::dict::get $F $fid OPT_NAMES]] == 0 && ![tcl::dict::get $F $fid OPT_ANY]} {
tcl::dict::set F $fid OPT_MAX 0 ;#aid in parsing to avoid scanning for opts unnecessarily tcl::dict::set F $fid OPT_MAX 0 ;#aid in parsing to avoid scanning for opts unnecessarily
@ -3292,8 +3384,8 @@ tcl::namespace::eval punk::args {
return true return true
} }
foreach d $rawdef { foreach d $rawdef {
if {[regexp {\s*(\S+)} $d _match firstword]} { if {[regexp {\s*(\S+)} $d _match first_rawdef_word]} {
if {$firstword eq "@dynamic"} { if {$first_rawdef_word eq "@dynamic"} {
return true return true
} }
} }
@ -3513,7 +3605,7 @@ tcl::namespace::eval punk::args {
} }
# -- --- --- --- --- --- # -- --- --- --- --- ---
set unscanned [punklib_ldiff $registered $scanned_packages] set unscanned [punk::args::system::punklib_ldiff $registered $scanned_packages]
if {[llength $unscanned]} { if {[llength $unscanned]} {
foreach pkgns $unscanned { foreach pkgns $unscanned {
set idcount 0 set idcount 0
@ -3562,7 +3654,7 @@ tcl::namespace::eval punk::args {
if {"*" in $nslist} { if {"*" in $nslist} {
set needed [punklib_ldiff $registered $loaded_packages] set needed [punk::args::system::punklib_ldiff $registered $loaded_packages]
} else { } else {
set needed [list] set needed [list]
foreach pkgns $nslist { foreach pkgns $nslist {
@ -4311,6 +4403,33 @@ tcl::namespace::eval punk::args {
set trie [punk::trie::trieclass new {*}$all_opts --] set trie [punk::trie::trieclass new {*}$all_opts --]
set idents [dict get [$trie shortest_idents ""] scanned] set idents [dict get [$trie shortest_idents ""] scanned]
if {[llength [dict get $form_dict OPT_MASHES]]} {
set all_mash_letters [dict get $form_dict OPT_ALL_MASH_LETTERS]
#now extend idents to be at least as long as the number of mash/bundle flags that exist.
#(when the flag itself is longer than number of mash flags
# - e.g for flags -x -v -c -f -collection, the ident for -collection would be -co normally
# but if we have 4 mash flags, we want it to be -colle to satisfy the requirement that it is longer then the number of mash flags
# unless it is an exact match.)
#
#e.g if all the single letter flags are configured with -mash true:
#our prefix calculation might give us the following idents:
# idents: -cabinet -ca -a -a -b -b -c -c -- --
#we need only to extend -cabinet to -cabi to satisfy the requirement that it is longer than the number of mash flags (3 in this example because -- is never a mash flag)
dict for {fullname ident} $idents {
set mashcount [llength $all_mash_letters]
#assert: if we are here - mashcount > 0
if {[string length $ident] < [string length $fullname] && [string length $ident] <= $mashcount} {
dict set idents $fullname [string range $fullname 0 $mashcount+1]
}
}
#note it's still possible for the user to define a flag with a name shorter than the number of mash flags
# and it could even overlap with a specific combination of mash letters - e.g -a -b -c -d and a flag named -bac
# - in this case a provided value of -bac would still match the flag -bac rather than being treated as a mash of -b -a -c
#because the exact match will take priority over the prefix match.
#Whilst this configuration is accepted - it's not recommended.
}
#todo - check opt_prefixdeny #todo - check opt_prefixdeny
$trie destroy $trie destroy
@ -7906,6 +8025,8 @@ tcl::namespace::eval punk::args {
#set OPT_MIN [dict get $formdict OPT_MIN] #set OPT_MIN [dict get $formdict OPT_MIN]
set OPT_MAX [dict get $formdict OPT_MAX] set OPT_MAX [dict get $formdict OPT_MAX]
#set OPT_SOLOS [dict get $formdict OPT_SOLOS] #set OPT_SOLOS [dict get $formdict OPT_SOLOS]
set OPT_MASHES [dict get $formdict OPT_MASHES]
set OPT_ALL_MASH_LETTERS [dict get $formdict OPT_ALL_MASH_LETTERS]
set OPTSPEC_DEFAULTS [dict get $formdict OPTSPEC_DEFAULTS] set OPTSPEC_DEFAULTS [dict get $formdict OPTSPEC_DEFAULTS]
set OPT_CHECKS_DEFAULTS [dict get $formdict OPT_CHECKS_DEFAULTS] set OPT_CHECKS_DEFAULTS [dict get $formdict OPT_CHECKS_DEFAULTS]
#set OPT_GROUPS [dict get $formdict OPT_GROUPS] #set OPT_GROUPS [dict get $formdict OPT_GROUPS]
@ -7956,8 +8077,11 @@ tcl::namespace::eval punk::args {
} }
} }
} }
#note all_opts will necessarily not include mashed flags (e.g -abc) when only -a -b -c are defined - but we will detect and break those down in the main loop below
set all_opts [dict keys $lookup_optset] set all_opts [dict keys $lookup_optset]
set ridx 0 set ridx 0
set rawargs_copy $rawargs set rawargs_copy $rawargs
set remaining_rawargs $rawargs set remaining_rawargs $rawargs
@ -8374,15 +8498,225 @@ tcl::namespace::eval punk::args {
#flagsupplied when --longopt=x is --longopt (may still be a prefix) #flagsupplied when --longopt=x is --longopt (may still be a prefix)
#get full flagname from possible prefix $flagsupplied #get full flagname from possible prefix $flagsupplied
set flagname [tcl::prefix match -error "" [list {*}$all_opts --] $flagsupplied] set flagname [tcl::prefix match -error "" [list {*}$all_opts --] $flagsupplied]
if {$flagname eq "--"} { #The prefix matching above doesn't consider that mashed flags can make shorter prefixes an invalid match for the whole flag.
set optionset "" #if the length of our matched flagname is less than the length of $OPT_ALL_MASH_LETTERS, then we may have a mash of other flags,
} else { #not a valid match for some longer flag that just happens to share the same prefix as the start of the mash.
if {[dict exists $lookup_optset $flagname]} { #we have defined valid prefix matches in the presence of mashed flags to be only those that are longer than any possible mash of flags
set optionset [dict get $lookup_optset $flagname]
} else { #(review - for small numbers of mashed flags we could be more precise, but the combinatoric explosion of longer mash lengths makes it
#simpler to just say any match that is shorter than the length of the longest possible mash is invalid
# we may need consider what common utilities do in practice regarding allowing prefixes in the presence of mashed flags
#- but it seems likely that they would either not allow prefixes at all, or only allow prefixes that are longer than any possible mash of flags)
#So if we have a match that isn't exact and is shorter than the length of the longest possible mash, we need to check if it's actually a mash of valid flags rather than a valid prefix match for a longer flag.
if {$flagname ne $flagsupplied && [llength $OPT_MASHES] && (([string length $flagsupplied] -1) <= [llength $OPT_ALL_MASH_LETTERS])} {
#invalidate the match
set flagname ""
}
switch -- $flagname {
-- {
set optionset "" set optionset ""
} }
"" {
#no match for flagname - could be a mashed flag e.g -abc where only -a -b -c are defined
if {![llength $OPT_MASHES]} {
#no mashed flags defined - so this probably isn't a flag - could be a value
set optionset ""
} else {
#check if every letter after the first matches a defined opt - if so treat as mashed flags
set mashflags [string range $flagsupplied 1 end]
set mashletters [split $mashflags ""]
set all_mashable true
foreach mf $mashletters {
if {$mf ni $OPT_ALL_MASH_LETTERS} {
set all_mashable false
break
}
}
#todo - move block below up here.
if {!$all_mashable} {
puts stderr "Debug: flagsupplied '$flagsupplied' not a valid flagname and not a valid mash of flags - treating as value"
#- probably isn't a flag at all - could be a value
#treat as value
set optionset ""
} else {
#puts stderr "Debug: flagsupplied '$flagsupplied' not a valid flagname but is a valid mash of flags - treating as mash of flags"
#treat as mashed flags - we will break down into individual flags and process each one in turn
set optionset $flagsupplied
#the -mash option means we may have to process multiple flags as received for one arg that looks like a flag
#we can still use the lookup_optset dict to get the optionset for each individual flag - as the keys of lookup_optset are all the individual flags (not mashed together)
#we need to update:
# vals_remaining_possible after processing all matchletters (by -1 or -2 depending on whether the mash includes a flag with an attached value (trailing=<val>) or accepts a value.)
# multisreceived
# soloreceived (if any of the flags in the mash are solo)
# flagsreceived (add the mash as received - but also add each individual flag in the mash as received for the purposes of checking for multiple and solo)
# opts (for each flag in the mash)
set posn 0
set consume_value 0 ;#if last mash flag accepts a value, we will consume the next arg as its value
foreach mf $mashletters {
set matchopt [dict get $lookup_optset -$mf]
if {$matchopt eq ""} {
#this should not happen as we have already checked all letters are mashable - but check just in case
puts stderr "Debug: mash letter '-$mf' not in lookup_optset - this should not happen"
} else {
#process each mashed flag as if it were received separately
#- we can reuse the same flagval for each as they won't be expected to have values (as they are single letter flags)
#we will still need to check for multiple and defaults for each individual flag
#we can also still use the same argstate entries for each individual flag as the optionset will be the same for each of the mashed flags (as they will all be defined in the same optionset e.g -a|-b|-c)
set mashflagname -$mf
set mashflagoptionset [dict get $lookup_optset $mashflagname]
set raw_optionset_members [split $mashflagoptionset |]
#set mashflagapiopt [dict get $argstate $mashflagoptionset -parsekey]
#if {$mashflagapiopt eq ""} {
# set mashflagapiopt [string trimright [lindex [split $mashflagoptionset |] end] =]
#}
set flagname -$mf
if {[tcl::dict::get $argstate $mashflagoptionset -parsekey] ne ""} {
set api_opt [dict get $argstate $mashflagoptionset -parsekey]
} else {
set api_opt [string trimright [lindex $raw_optionset_members end] =]
}
if {$api_opt eq $flagname} {
set flag_ident $api_opt
set flag_ident_is_parsekey 0
} else {
#initially key our opts on a long form allowing us to know which specific flag was used
#(for when multiple map to same parsekey e.g lsearch)
#e.g -increasing|-SORTOPTION
set flag_ident $flagname|$api_opt
set flag_ident_is_parsekey 1
}
set optionset_type [tcl::dict::get $argstate $mashflagoptionset -type]
#only the last flag in a mash can be allowed to have a value, and the other flags must be of type none.
#flags are by default optional.
if {$optionset_type ne "none"} {
#A flag with a value - only allowed for the last flag in a mash
if {$posn != [expr {[llength $mashletters] - 1}]} {
#not the last flag in the mash - can't have a value
set errmsg "bad options for %caller%. Flag \"$mashflagname\" in mash \"$flagsupplied\" cannot have a value as only the last flag in a mash can have a value. The flag \"$mashflagname\" must be of type none. (1)"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $all_opts] -badarg $a -argspecs $argspecs]] $errmsg
} else {
set consume_value 1
# ------------
#check if it was actually a value that looked like a flag
if {$i == $maxidx} {
#if no optvalue following - assume it's a value
#(caller should probably have used -- before it)
#review
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
break
}
#flagval comes from next remaining rawarg
set flagval [lindex $remaining_rawargs $i+1]
if {[tcl::dict::get $argstate $mashflagoptionset -multiple]} {
#don't lappend to default - we need to replace if there is a default
if {$api_opt ni $flagsreceived} {
tcl::dict::set opts $flag_ident [list $flagval]
} else {
tcl::dict::lappend opts $flag_ident $flagval
}
if {$api_opt ni $multisreceived} {
lappend multisreceived $api_opt
}
} else {
#tcl::dict::set opts $flag_ident $flagval
if {$flag_ident_is_parsekey} {
#necessary shimmer ?
lappend opts $flag_ident $flagval
} else {
tcl::dict::set opts $flag_ident $flagval
}
}
#incr i to skip flagval
#incr vals_remaining_possible -2
#if {[incr i] > $maxidx} {
# set msg "Bad options for %caller%. No value supplied for last option $mashflagoptionset at index [expr {$i-1}] which is not marked with -type none"
# return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $mashflagoptionset index [expr {$i-1}]] -badarg $mashflagoptionset -argspecs $argspecs]] $msg
#}
# ------------
}
} else {
#flag with no value - check for -typedefaults for the flag
#none / solo
if {[tcl::dict::exists $argstate $mashflagoptionset -typedefaults]} {
set tdflt [tcl::dict::get $argstate $mashflagoptionset -typedefaults]
} else {
#normal default for a solo is 1 unless overridden by -typedefaults
set tdflt 1
}
if {[tcl::dict::get $argstate $mashflagoptionset -multiple]} {
#puts stderr "Debug: flag '$mashflagname' in mash '$flagsupplied' is a multiple with typedefaults $tdflt -- api_opt: $api_opt flag_ident: $flag_ident flagsreceived: $flagsreceived multisreceived: $multisreceived"
if {$api_opt ni $flagsreceived} {
#override any default - don't lappend to it
tcl::dict::set opts $flag_ident $tdflt
} else {
tcl::dict::lappend opts $flag_ident $tdflt
}
if {$api_opt ni $multisreceived} {
lappend multisreceived $api_opt
}
} else {
#test parse_withdef_parsekey_repeat_ordering {Ensure last flag has precedence}
#tcl::dict::set opts $flag_ident $tdflt
if {$flag_ident_is_parsekey} {
#(shimmer - but required for ordering correctness during override)
puts stderr "Debug: flag '$mashflagname' in mash '$flagsupplied' flag_ident '$flag_ident' is the same as parsekey '$api_opt' tdflt: $tdflt - using lappend to ensure it ends up after any previous flag in the mash that had the same parsekey"
lappend opts $flag_ident $tdflt
puts stderr "opts after lappend: $opts"
} else {
tcl::dict::set opts $flag_ident $tdflt
}
}
#incr vals_remaining_possible -1
lappend solosreceived $api_opt ;#dups ok
}
}
lappend flagsreceived $api_opt
incr posn
}
#update vals_remaining_possible by one or 2 if the last flag took a value.
incr vals_remaining_possible -1
if {$flagval_included || $consume_value} {
incr vals_remaining_possible -1
}
#after processing the mash, we will have updated opts for each individual flag in the mash,
#and updated multisreceived and solo_received as needed based on the optionset entries for each individual flag in the mash
#we possibly need to incr i to skip a received value for the mash if the last flag in the mash had a value.
#or break if we have reached the end of the args after processing the mash
if {$flagval_included || $consume_value} {
#the last flag in the mash had a value - we have already processed it for that flag - so we need to skip it for the next iteration of the loop
incr i
if {$i > $maxidx} {
#we have reached the end of the args after processing the mash and its value - so we can break out of the loop
break
}
} else {
#no value included for the last flag in the mash - so we just continue to the next iteration of the loop to process the next arg
}
continue
}
}
}
default {
if {[dict exists $lookup_optset $flagname]} {
set optionset [dict get $lookup_optset $flagname]
} else {
#we matched a prefix of all_opts - but it's not in the lookup_optset?
#review - this should not happen as we only match prefixes from all_opts which is derived from the keys of lookup_optset
puts stderr "Debug: matched prefix '$flagname' not in lookup_optset - this should not happen"
set optionset ""
}
}
} }
if {$optionset ne ""} { if {$optionset ne ""} {
#matched some option - either in part or in full. #matched some option - either in part or in full.
set raw_optionset_members [split $optionset |] set raw_optionset_members [split $optionset |]
@ -9205,7 +9539,7 @@ tcl::namespace::eval punk::args {
#} #}
#for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us
if {[llength $LEADER_REQUIRED]} { if {[llength $LEADER_REQUIRED]} {
if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { if {[llength [set missing [punk::args::system::punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} {
set msg "Required leader missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" 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 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 #arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs
@ -9213,7 +9547,7 @@ tcl::namespace::eval punk::args {
} }
if {[llength $OPT_REQUIRED]} { if {[llength $OPT_REQUIRED]} {
set api_opt_required [lmap v $OPT_REQUIRED {lindex [split $v |] end}] set api_opt_required [lmap v $OPT_REQUIRED {lindex [split $v |] end}]
if {[llength [set missing [punklib_ldiff $api_opt_required $flagsreceived]]]} { if {[llength [set missing [punk::args::system::punklib_ldiff $api_opt_required $flagsreceived]]]} {
set full_missing [list] set full_missing [list]
foreach m $missing { foreach m $missing {
lappend full_missing [dict get $lookup_optset $m] lappend full_missing [dict get $lookup_optset $m]
@ -9225,7 +9559,7 @@ tcl::namespace::eval punk::args {
} }
} }
if {[llength $VAL_REQUIRED]} { if {[llength $VAL_REQUIRED]} {
if {[llength [set missing [punklib_ldiff $VAL_REQUIRED $valnames_received]]]} { if {[llength [set missing [punk::args::system::punklib_ldiff $VAL_REQUIRED $valnames_received]]]} {
set msg "Required value missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" 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 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 #arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs
@ -10026,8 +10360,8 @@ tcl::namespace::eval punk::args {
set alternates [list];#alternate acceptable types e.g literal(yes)|literal(ok) or indexpression|literal(first) set alternates [list];#alternate acceptable types e.g literal(yes)|literal(ok) or indexpression|literal(first)
set type_alternatives [_split_type_expression $tp] set type_alternatives [_split_type_expression $tp]
foreach tp_alternative $type_alternatives { foreach tp_alternative $type_alternatives {
set firstword [lindex $tp_alternative 0] set tp_alternative_word1 [lindex $tp_alternative 0]
switch -exact -- $firstword { switch -exact -- $tp_alternative_word1 {
literal { literal {
set match [lindex $tp_alternative 1] set match [lindex $tp_alternative 1]
lappend alternates $match lappend alternates $match
@ -11485,7 +11819,7 @@ tcl::namespace::eval punk::args::package {
-return\ -return\
-type string\ -type string\
-default table\ -default table\
-choices {string table tableobject}\ -choices {string table tableobject dict}\
-choicelabels { -choicelabels {
string\ string\
"A basic text layout" "A basic text layout"
@ -11564,19 +11898,25 @@ tcl::namespace::eval punk::args::package {
} }
} }
} }
if {$opt_return ne "string"} {
package require textblock ;#table support
set is_table 1
set title [string cat {[} $pkgname {]} ]
set t [textblock::class::table new -title $title]
$t configure -frametype double -minwidth [expr {[string length $title]+2}]
} else { set is_table 0
set topiclens [lmap t $topics {string length $t}] switch -- $opt_return {
set widest_topic [tcl::mathfunc::max {*}$topiclens] table - tableobject {
set is_table 0 package require textblock ;#table support
set about "$pkgname\n" set is_table 1
append about [string repeat - $widest_topic] \n set title [string cat {[} $pkgname {]} ]
set t [textblock::class::table new -title $title]
$t configure -frametype double -minwidth [expr {[string length $title]+2}]
}
string {
set topiclens [lmap t $topics {string length $t}]
set widest_topic [tcl::mathfunc::max {*}$topiclens]
set about "$pkgname\n"
append about [string repeat - $widest_topic] \n
}
dict {
set about [dict create]
}
} }
foreach topic $topics { foreach topic $topics {
if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} {
@ -11584,14 +11924,20 @@ tcl::namespace::eval punk::args::package {
} else { } else {
set topic_contents "<unavailable>" set topic_contents "<unavailable>"
} }
if {!$is_table} { switch -- $opt_return {
set content_lines [split $topic_contents \n] table - tableobject {
append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n $t add_row [list $topic $topic_contents]
foreach ln [lrange $content_lines 1 end] { }
append about [format %-${widest_topic}s ""] " " $ln \n string {
set content_lines [split $topic_contents \n]
append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n
foreach ln [lrange $content_lines 1 end] {
append about [format %-${widest_topic}s ""] " " $ln \n
}
}
dict {
dict set about $topic $topic_contents
} }
} else {
$t add_row [list $topic $topic_contents]
} }
} }
@ -11662,6 +12008,121 @@ tcl::namespace::eval punk::args::system {
} }
# == === === === === === === === === === === === === === ===
# Sample 'about' function with punk::args documentation
# == === === === === === === === === === === === === === ===
tcl::namespace::eval punk::args {
namespace eval argdoc {
#namespace for custom argument documentation
namespace import ::punk::args::helpers::*
proc package_name {} {
return punk::args
}
proc about_topics {} {
#info commands results are returned in an arbitrary order (like array keys)
set topic_funs [info commands [namespace current]::get_topic_*]
set about_topics [list]
foreach f $topic_funs {
set tail [namespace tail $f]
lappend about_topics [string range $tail [string length get_topic_] end]
}
#Adjust this function or 'default_topics' if a different order is required
return [lsort $about_topics]
}
proc default_topics {} {return [list Description *]}
# -------------------------------------------------------------
# get_topic_ functions add more to auto-include in about topics
# -------------------------------------------------------------
proc get_topic_Description {} {
punk::args::lib::tstr -indent " " [string trim {
package punk::args
Argument parsing library for Tcl.
Can be used purely for documentation of arguments and options, or also for actual argument parsing in procs.
supports longopts-style options, subcommands, and generation of help text.
"mash options" aka "short option bundling" or "flag/option stacking"
punk::args supports mash options for single letter flags that don't take arguments, e.g -a -b -c -> -abc or -bac etc
The last option in a mash can take an argument, e.g -x -v -f <filename> -> -xvf <filename>
Note the number of permutations of options with mashing can get large quickly.
(e.g 10 flags would have 10! = 3,628,800 permutations if all could be mashed together)
This has implications if we also support unique abbreviations of options as every permutation of the mashing
would need to be checked for conflicts with other options and their abbreviations.
The chosen solution is to determine the longest possible mashes for a given set of options, and then require
any abbreviations of other -options to be longer than the longest mash, so that there is no ambiguity between
an abbreviation and a mash.
E.g if we have -mash true and the options -a -b -c -d -backwards -cabinet -call, then the longest mash/bundle is 4 chars
(-abcd -bacd etc), so using the longest mash/bundle length of 4, we require that any abbreviation of other options must be at
least 5 chars long.
In this case -backwards could be abbreviated to -backw or -backwa etc, but not to -ba, -bac or -back.
As an exact match; -call would be accepted.
Whilst in this specific case -back is theoretically unambiguous - we still stick to the rule of requiring abbreviations to be
longer than the longest mash, to keep the rules simple and consistent; and so easier to process and to predict and reason about.
Although the combinations of -a -b -c -d are manageable in this case, if we had more single-letter options we would
not want to use a huge number of combinations of mashes to calculate the allowable prefix matches.
we calculate prefixes based on the flag names as usual, but extend the required prefixes of options such as -cabinet to be longer
(-cab extended to -cabin, -cal extended to -call).
} \n]
}
proc get_topic_License {} {
return " BSD 3-Clause"
}
proc get_topic_Version {} {
return " $::punk::args::version"
}
proc get_topic_Contributors {} {
set authors {{Julian Noble <julian@precisium.com.au>}}
set contributors ""
foreach a $authors {
append contributors $a \n
}
if {[string index $contributors end] eq "\n"} {
set contributors [string range $contributors 0 end-1]
}
return [punk::lib::tstr -indent " " $contributors]
}
proc get_topic_notes {} {
punk::args::lib::tstr -indent " " -return string {
see output of:
punk::args::usage ::punk::args::parse
As a convenience in a shell with the various punk packages loaded, you can also do:
i punk::args::parse
Here i is an alias for punk::ns::cmdhelp which allows lookup of unqualified command names
based on the current context.
}
}
# -------------------------------------------------------------
}
# we re-use the argument definition from punk::args::standard_about and override some items
set overrides [dict create]
dict set overrides @id -id "::punk::args::about"
dict set overrides @cmd -name "punk::args::about"
dict set overrides @cmd -help [string trim [punk::args::lib::tstr {
About punk::args
}] \n]
dict set overrides topic -choices [list {*}[punk::args::argdoc::about_topics] *]
dict set overrides topic -choicerestricted 1
dict set overrides topic -default [punk::args::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *]
lappend PUNKARGS [list $newdef]
proc about {args} {
package require punk::args
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on
set argd [punk::args::parse $args withid ::punk::args::about]
lassign [dict values $argd] _leaders opts values _received
punk::args::package::standard_about -package_about_namespace ::punk::args::argdoc {*}$opts {*}[dict get $values topic]
}
}
# end of sample 'about' function
# == === === === === === === === === === === === === === ===
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready ## Ready

2
src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tclcore-0.1.0.tm

@ -3315,7 +3315,7 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
Each element except ${$B}type${$N} is a decimal string with the value of the corresponding field from the Each element except ${$B}type${$N} is a decimal string with the value of the corresponding field from the
stat return structure; see the manual entry for stat for details on the meanings of the values. stat return structure; see the manual entry for stat for details on the meanings of the values.
The type element gives the type of the file in the same form returned by the command ${$B}file type${$N}." The type element gives the type of the file in the same form returned by the command ${$B}file type${$N}."
@values -min 1 -max 1 @values -min 1 -max 2
name -optional 0 -type string name -optional 0 -type string
varName -type string -optional 1 varName -type string -optional 1
} "@doc -name Manpage: -url [manpage_tcl file]"] } "@doc -name Manpage: -url [manpage_tcl file]"]

19
src/vfs/_vfscommon.vfs/modules/punk/nav/ns-0.1.0.tm

@ -54,12 +54,19 @@ tcl::namespace::eval punk::nav::ns {
n// p* - list namespaces below current and commands in current matching p* n// p* - list namespaces below current and commands in current matching p*
} }
@values -min 1 -max -1 -type string @values -min 1 -max -1 -type string
v -type string -choices {/ //} -help\ v -type string\
" -choices {/ // ///}\
/ - list namespaces only -choicelabels {
// - list namespaces and commands /\
/// - list namespaces, commands and commands resolvable via 'namespace path' "list namespaces only"
" //\
"list namespaces and commands"
///\
"list namespaces, commands and commands
resolvable via 'namespace path'"
}\
-help\
"The form of navigation/listing to perform."
nsglob -type string -optional true -multiple true -help\ nsglob -type string -optional true -multiple true -help\
"A glob pattern supporting placeholders * and ?, to filter results. "A glob pattern supporting placeholders * and ?, to filter results.
If multiple patterns are supplied, then a listing for each pattern is returned. If multiple patterns are supplied, then a listing for each pattern is returned.

148
src/vfs/_vfscommon.vfs/modules/punk/repo-0.1.1.tm

@ -85,25 +85,40 @@ namespace eval punk::repo {
set allcmds [runout -n fossil help -a] set allcmds [runout -n fossil help -a]
set mainhelp [runout -n fossil help] set mainhelp [runout -n fossil help]
set maincommands [list] set maincommands [list]
#only start parsing for TOPICS after a line such as "Other comman values for TOPIC:"
set parsing_topics 0
foreach ln [split $mainhelp \n] { foreach ln [split $mainhelp \n] {
set ln [string trim $ln] set ln [string trim $ln]
if {$ln eq "" || [regexp {^[A-Z]+} $ln]} { if {$ln eq ""} {
continue continue
} }
lappend maincommands {*}$ln if {[string match "*values for TOPIC*" $ln]} {
set parsing_topics 1
continue
}
if {$parsing_topics} {
#lines starting with uppercase are topic headers - we want to ignore these and any blank lines
if {[regexp {^[A-Z]+} $ln]} {
continue
}
lappend maincommands {*}$ln
}
} }
#fossil output was ordered in columns, but we loaded list in row-wise, messing up the order #fossil output was ordered in columns, but we loaded list in row-wise, messing up the order
set maincommands [lsort $maincommands] set maincommands [lsort $maincommands]
set allcmds [lsort $allcmds] set allcmds [lsort $allcmds]
set othercmds [punk::lib::ldiff $allcmds $maincommands] set othercmds [punk::lib::ldiff $allcmds $maincommands]
set fossil_setting_names [lsort [runout -n fossil help -s]]
set result "@leaders -min 0\n" set result "@leaders -min 0\n"
append result [tstr -return string { append result [tstr -return string {
subcommand -type string -choicecolumns 8 -choicegroups { subcommand -type string -choicecolumns 8 -choicegroups {
"frequently used commands" {${$maincommands}} "frequently used commands" {${$maincommands}}
"" {${$othercmds}} "" {${$othercmds}}
} -choiceinfo {add {{doctype punkargs}} diff {{doctype punkargs}}} } -choiceprefixreservelist {${$fossil_setting_names}} -choiceinfo {add {{doctype punkargs}} diff {{doctype punkargs}}}
}] }]
#-choiceinfo { #-choiceinfo {
# add {{doctype punkargs}} # add {{doctype punkargs}}
@ -132,20 +147,127 @@ namespace eval punk::repo {
#experiment #experiment
lappend PUNKARGS [list {
@dynamic proc get_fossil_subcommand_usage {subcmd} {
@id -id "::punk::repo::fossil_proxy diff" set result ""
@cmd -name "fossil diff" -help "fossil diff" append result "@leaders -min 0 -max 0\n"
@formdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}} append result "@opts\n"
} ""] #The -o output sometimes includes portions of the general help text that happens to describe options.
#e.g fossil help diff -o includes
# "--webpage -y HTML output in the side-by-side format"
#as well as:
#" --webpage Format output as a stand-alone HTML webpage"
# we also get duplicates for --tk --by -b -y
#this suggests -o just does a basic parsing of the usage text and pulls out anything that looks like an option.
#other commands such as: fossil help fdiff -o
# return no options - but the help text states that fdiff accepts the same options as diff.
set basic_opt_lines [split [runout -n fossil help $subcmd -o] \n]
set help_lines [split [runout -n fossil help $subcmd] \n]
#first set of lines are for Usage:
#e.g
# % fossil help diff
# Usage: fossil diff|gdiff ?OPTIONS? FILE1 ?FILE2 ...?
# % fossil help ls
# Usage: fossil ls ?OPTIONS? ?PATHS ...?
#When there are multiple forms of usage we may get some "or:" lines.
#e.g
# % fossil help commit
# Usage: fossil commit ?OPTIONS? ?FILE...?
# or: fossil ci ?OPTIONS? ?FILE...?
# % fossil help mv
# Usage: fossil mv|rename ?OPTIONS? OLDNAME NEWNAME
# or: fossil mv|rename ?OPTIONS? OLDNAME... DIR
#(at least some "unsupported" test- commands don't provide a Usage line at all - e.g fossil help test-http)
foreach ln $basic_opt_lines {
set ln [string trim $ln]
if {$ln eq ""} {
continue
}
#the truncated description lines aren't useful here - but are always separated from the option info by more than one space.
set colbreak [string first " " $ln] ;#first occurrence of 2 spaces in a row - which is the separator between option info and description in fossil help output
set optinfo [string range $ln 0 $colbreak-1]
#this isn't the full help info for the option - but it's what we have available in the output of 'fossil help subcmd -o' - which is more concise and easier to parse than the full help for each option.
#todo - call fossil help <subcmd> and retrieve full help for each option.
set temphelp [string range $ln $colbreak end]
set opthelp [string trim $temphelp]
#we expect either one or two parts.
lassign $optinfo namepart typepart
#e.g --case-sensitive BOOL
#e.g -v|--verbose
#e.g -ci|--checkin VERSION (convert to -ci|--checkin=|--checkin -type VERSION)
if {$typepart ne ""} {
set optnames [split $namepart "|"]
#rebuild optnames as punkoptiondef string retaining dashes and pipes but adding in additional forms for longopts - e.g -ci|--checkin becomes -ci|--checkin=|--checkin
set punknames [list]
foreach n $optnames {
if {[string match --* $n]} {
#set n [list $n [string range $n 2 end]= [string range $n 2 end]]
lappend punknames $n ${n}=
} elseif {[string match -* $n]} {
lappend punknames $n
} else {
error "Unexpected option format: $n"
}
}
set typepart "-type $typepart"
} else {
#use as is if the flag doesn't have an argument - e.g -v|--verbose
set punknames $namepart
set typepart "-type none"
}
set punkoptiondef [join $punknames "|"]
append result [tstr -return string {
${$punkoptiondef} ${$typepart} -help {${$opthelp}}
}]
}
append result [tstr -return string {
@values -min 1 -max -1
file -type string -multiple 1 -help "file or directory to add to fossil"
}]
return $result
}
lappend PUNKARGS [list { lappend PUNKARGS [list {
#todo - remove this comment - testing dynamic directive #todo - remove this comment - testing dynamic directive
@dynamic @dynamic
@id -id "::punk::repo::fossil_proxy add" @id -id "::punk::repo::fossil_proxy add"
@cmd -name "fossil add" -help "fossil add @cmd -name "fossil add"\
" -summary\
""\
-help "fossil add"
@form -form "parsed"
${[punk::repo::get_fossil_subcommand_usage add]}
@form -form "raw" -synopsis "exec fossil add ?OPTIONS? FILE1 ?FILE2 ...?"
@formdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} @formdisplay -header "fossil help add" -body {${[runout -n fossil help add]}}
} ""] } ""]
lappend PUNKARGS [list {
@id -id "::punk::repo::fossil_proxy diff"
@cmd -name "fossil diff"\
-summary\
""\
-help\
"fossil diff"
@form -form "parsed"
${[punk::repo::get_fossil_subcommand_usage diff]}
@form -form "raw" -synopsis "exec fossil diff ?OPTIONS? FILE1 ?FILE2 ...?"
@formdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}}
} ""]
#TODO #TODO
#lappend PUNKARGS [list { #lappend PUNKARGS [list {
# @dynamic # @dynamic

BIN
src/vfs/_vfscommon.vfs/modules/test/punk/args-0.1.5.tm

Binary file not shown.
Loading…
Cancel
Save