jn
/
punkshell
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

tomlish and punk::netbox improvements

master
Julian Noble 2 weeks ago
parent
c9281f0810
commit
a04a62d2e9
19 changed files with 25823 additions and 1010 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 326
      src/bootsupport/modules/punk/args-0.1.0.tm
  2. 153
      src/bootsupport/modules/punk/path-0.1.0.tm
  3. 31
      src/bootsupport/modules/textblock-0.1.3.tm
  4. 5566
      src/bootsupport/modules/tomlish-1.1.2.tm
  5. 326
      src/modules/punk/args-999999.0a1.0.tm
  6. 1298
      src/modules/punk/imap4-999999.0a1.0.tm
  7. 1228
      src/modules/punk/netbox-999999.0a1.0.tm
  8. 3
      src/modules/punk/netbox-buildversion.txt
  9. 153
      src/modules/punk/path-999999.0a1.0.tm
  10. 31
      src/modules/textblock-999999.0a1.0.tm
  11. 326
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm
  12. 153
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm
  13. 31
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm
  14. 5566
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.2.tm
  15. 326
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm
  16. 153
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm
  17. 31
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm
  18. 5566
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/tomlish-1.1.2.tm
  19. 5566
      src/vendormodules/tomlish-1.1.2.tm

326
src/bootsupport/modules/punk/args-0.1.0.tm
Unescape View File

@ -331,26 +331,26 @@ tcl::namespace::eval punk::args {
parsing and help display. parsing and help display.
directives include: directives include:
%B%@id%N% ?opt val...? %B%@id%N% ?opt val...?
options: -id <str> spec-options: -id <str>
%B%@cmd%N% ?opt val...? %B%@cmd%N% ?opt val...?
options: -name <str> -help <str> spec-options: -name <str> -help <str>
%B%@leaders%N% ?opt val...? %B%@leaders%N% ?opt val...?
options: -min <int> -max <int> spec-options: -min <int> -max <int>
(used for leading args that come before switches/opts) (used for leading args that come before switches/opts)
%B%@opts%N% ?opt val...? %B%@opts%N% ?opt val...?
options: -any <bool> spec-options: -any <bool>
%B%@values%N% ?opt val...? %B%@values%N% ?opt val...?
options: -min <int> -max <int> spec-options: -min <int> -max <int>
(used for trailing args that come after switches/opts) (used for trailing args that come after switches/opts)
%B%@argdisplay%N% ?opt val...? %B%@argdisplay%N% ?opt val...?
options: -header <str> (text for header row of table) spec-options: -header <str> (text for header row of table)
-body <str> (text to replace autogenerated arg info) -body <str> (text to replace autogenerated arg info)
%B%@doc%N% ?opt val...? %B%@doc%N% ?opt val...?
options: -name <str> -url <str> spec-options: -name <str> -url <str>
%B%@seealso%N% ?opt val...? %B%@seealso%N% ?opt val...?
options: -name <str> -url <str> (for footer - unimplemented) spec-options: -name <str> -url <str> (for footer - unimplemented)
Some other options normally present on custom arguments are available Some other spec-options normally present on custom arguments are available
to use with the @leaders @opts @values directives to set defaults to use with the @leaders @opts @values directives to set defaults
for subsequent lines that represent your custom arguments. for subsequent lines that represent your custom arguments.
These directives should occur in exactly this order - but can be These directives should occur in exactly this order - but can be
@ -361,7 +361,12 @@ tcl::namespace::eval punk::args {
or using the i <cmd>.. function - an @id with -id <value> is needed. or using the i <cmd>.. function - an @id with -id <value> is needed.
All directives can be omitted, in which case every line represents All directives can be omitted, in which case every line represents
a custom value or option. a custom leader, value or option.
All will be leaders by default if no options defined.
If options are defined (by naming with leading dash, or explicitly
specifying @opts) then the definitions prior to the options will be
categorised as leaders, and those following the options will be
categorised as values.
Custom arguments are defined by using any word at the start of a Custom arguments are defined by using any word at the start of a
line that doesn't begin with @ or - line that doesn't begin with @ or -
@ -369,7 +374,7 @@ tcl::namespace::eval punk::args {
that @@somearg becomes an argument named @somearg) that @@somearg becomes an argument named @somearg)
custom leading args, switches/options (names starting with -) custom leading args, switches/options (names starting with -)
and trailing values also take options: and trailing values also take spec-options:
-type <typename> -type <typename>
defaults to string. If no other restrictions defaults to string. If no other restrictions
@ -397,12 +402,22 @@ tcl::namespace::eval punk::args {
-optional <boolean> -optional <boolean>
(defaults to true for flags/switches false otherwise) (defaults to true for flags/switches false otherwise)
For non flag/switch arguments - all arguments with
-optional true must sit consecutively within their group.
ie all optional leader arguments must be together, and all
optional value arguments must be together. Furthermore,
specifying both optional leaders and optional values will
often lead to ambiguous parsing results. Currently, all
optional non-flg/switch arguments should be either at the
trailing end of leaders or the trailing end of values.
Further unambiguous arrangements of optional args may be
made in future - but are currently considered 'unsupported'
-default <value> -default <value>
-multiple <bool> (for leaders & values defines whether -multiple <bool> (for leaders & values defines whether
subsequent received values are stored agains the same subsequent received values are stored against the same
argument name - only applies to final leader or value) argument name - only applies to final leader OR final value)
(for options/flags this allows the opt-val pair or solo (for options/flags this allows the opt-val pair or solo
flag to appear multiple times - no necessarily contiguously) flag to appear multiple times - not necessarily contiguously)
-choices {<choicelist>} -choices {<choicelist>}
A list of allowable values for an argument. A list of allowable values for an argument.
The -default value doesn't have to be in the list. The -default value doesn't have to be in the list.
@ -438,7 +453,7 @@ tcl::namespace::eval punk::args {
Max of -1 represents no upper limit. Max of -1 represents no upper limit.
If <range> allows more than one choice the value is a list If <range> allows more than one choice the value is a list
consisting of items in the choices made available through consisting of items in the choices made available through
entries in -choices/-choicegrups. entries in -choices/-choicegroups.
-minsize (type dependant) -minsize (type dependant)
-maxsize (type dependant) -maxsize (type dependant)
-range (type dependant) -range (type dependant)
@ -1667,6 +1682,7 @@ tcl::namespace::eval punk::args {
" "
@leaders -min 0 -max 0 @leaders -min 0 -max 0
@opts @opts
-return -default text -choices {text dict}
-form -default 0 -help\ -form -default 0 -help\
"Ordinal index or name of command form" "Ordinal index or name of command form"
@ -1694,7 +1710,7 @@ tcl::namespace::eval punk::args {
(directives are lines beginning with (directives are lines beginning with
@ e.g @id, @cmd etc) @ e.g @id, @cmd etc)
if -type is @leaders,@opts or @values matches from that type if -type is leaders,opts or values matches from that type
will be returned. will be returned.
if -type is another directive such as @id, @doc etc the if -type is another directive such as @id, @doc etc the
@ -1706,8 +1722,10 @@ tcl::namespace::eval punk::args {
proc resolved_def {args} { proc resolved_def {args} {
#not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only.
set opts [dict create\ set opts [dict create\
-types {}\ -return text\
-types {}\
-form 0\ -form 0\
-antiglobs {}\ -antiglobs {}\
-override {}\ -override {}\
@ -1743,7 +1761,7 @@ tcl::namespace::eval punk::args {
} }
dict for {k v} $opts { dict for {k v} $opts {
switch -- $k { switch -- $k {
-form - -types - -antiglobs - -override {} -return - -form - -types - -antiglobs - -override {}
default { default {
punk::args::parse $args withid ::punk::args::resolved_def punk::args::parse $args withid ::punk::args::resolved_def
return return
@ -1764,163 +1782,185 @@ tcl::namespace::eval punk::args {
variable id_cache_rawdef variable id_cache_rawdef
set realid [real_id $id] set realid [real_id $id]
if {$realid eq ""} {
return
}
if {$realid ne ""} { set deflist [tcl::dict::get $id_cache_rawdef $realid]
set deflist [tcl::dict::get $id_cache_rawdef $realid] set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]]
set result ""
set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]]
set opt_form [dict get $opts -form] set opt_form [dict get $opts -form]
if {[string is integer -strict $opt_form]} { if {[string is integer -strict $opt_form]} {
set formname [lindex [dict get $specdict form_names] $opt_form] set formname [lindex [dict get $specdict form_names] $opt_form]
} else { } else {
set formname $opt_form set formname $opt_form
} }
set opt_override [dict get $opts -override] set opt_override [dict get $opts -override]
set opt_return [dict get $opts -return]
#set arg_info [dict get $specdict ARG_INFO]
set arg_info [dict get $specdict FORMS $formname ARG_INFO] #set arg_info [dict get $specdict ARG_INFO]
set argtypes [dict create leaders leader opts option values value] set arg_info [dict get $specdict FORMS $formname ARG_INFO]
set argtypes [dict create leaders leader opts option values value]
set opt_antiglobs [dict get $opts -antiglobs]
set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] set opt_antiglobs [dict get $opts -antiglobs]
set suppressed_directives [list] set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *]
set suppressed_args [list] set suppressed_directives [list]
foreach ag $opt_antiglobs { set suppressed_args [list]
foreach d $directives { foreach ag $opt_antiglobs {
if {[string match $ag $d]} { foreach d $directives {
lappend suppressed_directives $d if {[string match $ag $d]} {
} lappend suppressed_directives $d
} }
foreach argname [dict keys $arg_info] { }
if {[string match $ag $argname]} { foreach argname [dict keys $arg_info] {
lappend suppressed_args $argname if {[string match $ag $argname]} {
} lappend suppressed_args $argname
} }
} }
set suppressed_directives [lsort -unique $suppressed_directives] }
set suppressed_args [lsort -unique $suppressed_args] set suppressed_directives [lsort -unique $suppressed_directives]
set suppressed_args [lsort -unique $suppressed_args]
set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives]
set globbed [list] set globbed [list]
foreach pat $patterns { foreach pat $patterns {
set matches [dict keys $arg_info $pat] set matches [dict keys $arg_info $pat]
lappend globbed {*}$matches lappend globbed {*}$matches
} }
set globbed [lsort -unique $globbed] set globbed [lsort -unique $globbed]
set included_args [punk::args::system::punklib_ldiff $globbed $suppressed_args] set included_args [punk::args::system::punklib_ldiff $globbed $suppressed_args]
foreach type $typelist {
switch -exact -- $type {
* {
if {"@id" in $included_directives} {
if {[dict exists $opt_override @id]} {
append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]"
} else {
append result \n "@id -id [dict get $specdict id]"
}
}
foreach directive {@package @cmd @doc @seealso @argdisplay} {
set dshort [string range $directive 1 end]
if {"$directive" in $included_directives} {
if {[dict exists $opt_override $directive]} {
append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]"
} else {
append result \n "$directive [dict get $specdict ${dshort}_info]"
}
}
}
#output ordered by leader, option, value
foreach pseudodirective {leaders opts values} tp {leader option value} {
set directive "@$pseudodirective"
switch -- $directive {
@leaders {set defaults_key leaderspec_defaults}
@opts {set defaults_key optspec_defaults}
@values {set defaults_key valspec_defaults}
}
if {"$directive" in $included_directives} {
if {[dict exists $opt_override "$directive"]} {
append result \n "$directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]"
} else {
append result \n "$directive [dict get $specdict $defaults_key]"
}
}
if {$pseudodirective in $included_directives} { set result ""
foreach m $included_args { set resultdict [dict create]
set argspec [dict get $arg_info $m] foreach type $typelist {
if {[dict get $argspec -ARGTYPE] eq $tp} { switch -exact -- $type {
set argspec [dict remove $argspec -ARGTYPE] * {
if {[dict exists $opt_override $m]} { if {"@id" in $included_directives} {
append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" if {[dict exists $opt_override @id]} {
} else { append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]"
append result \n "$m $argspec" dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]
} } else {
} append result \n "@id -id [dict get $specdict id]"
} dict set resultdict @id [list -id [dict get $specdict id]]
}
} }
} }
@id { foreach directive {@package @cmd @doc @seealso @argdisplay} {
if {"@id" in $included_directives} { set dshort [string range $directive 1 end]
#only a single id record can exist if {"$directive" in $included_directives} {
if {[dict exists $opt_override @id]} { if {[dict exists $opt_override $directive]} {
append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]"
dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]
} else { } else {
append result \n "@id -id [dict get $specdict id]" append result \n "$directive [dict get $specdict ${dshort}_info]"
dict set resultdict $directive [dict get $specdict ${dshort}_info]
} }
} }
} }
@package - @cmd - @doc - @seealso - @argdisplay { #output ordered by leader, option, value
if {"$type" in $included_directives} { foreach pseudodirective {leaders opts values} tp {leader option value} {
set tp [string range $type 1 end] ;# @package -> package set directive "@$pseudodirective"
if {[dict exists $opt_override $type]} { switch -- $directive {
append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" @leaders {set defaults_key leaderspec_defaults}
} else { @opts {set defaults_key optspec_defaults}
append result \n "$type [dict get $specdict ${tp}_info]" @values {set defaults_key valspec_defaults}
}
} }
}
@leaders - @opts - @values { if {"$directive" in $included_directives} {
#these are the active defaults for further arguments if {[dict exists $opt_override "$directive"]} {
if {"$type" in $included_directives} { append result \n "$directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]"
switch -- $type { dict set resultdict $directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]
@leaders {set defaults_key leaderspec_defaults}
@opts {set defaults_key optspec_defaults}
@values {set defaults_key valspec_defaults}
}
if {[dict exists $opt_override $type]} {
append result \n "$type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]]"
} else { } else {
append result \n "$type [dict get $specdict leaderspec_defaults]" append result \n "$directive [dict get $specdict $defaults_key]"
dict set resultdict $directive [dict get $specdict $defaults_key]
} }
} }
}
leaders - opts - values { if {$pseudodirective in $included_directives} {
#pseudo-directives
if {$type in $included_directives} {
foreach m $included_args { foreach m $included_args {
set argspec [dict get $arg_info $m] set argspec [dict get $arg_info $m]
if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { if {[dict get $argspec -ARGTYPE] eq $tp} {
set argspec [dict remove $argspec -ARGTYPE] set argspec [dict remove $argspec -ARGTYPE]
if {[dict exists $opt_override $m]} { if {[dict exists $opt_override $m]} {
append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" append result \n "$m [dict merge $argspec [dict get $opt_override $m]]"
dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]]
} else { } else {
append result \n "$m $argspec" append result \n "$m $argspec"
dict set resultdict $m $argspec
} }
} }
} }
} }
} }
default {
}
@id {
if {"@id" in $included_directives} {
#only a single id record can exist
if {[dict exists $opt_override @id]} {
append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]"
dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]
} else {
append result \n "@id -id [dict get $specdict id]"
dict set resultdict @id [list -id [dict get $specdict id]]
}
} }
} }
@package - @cmd - @doc - @seealso - @argdisplay {
if {"$type" in $included_directives} {
set tp [string range $type 1 end] ;# @package -> package
if {[dict exists $opt_override $type]} {
append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]"
dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]
} else {
append result \n "$type [dict get $specdict ${tp}_info]"
dict set resultdict $type [dict get $specdict ${tp}_info]
}
}
}
@leaders - @opts - @values {
#these are the active defaults for further arguments
if {"$type" in $included_directives} {
switch -- $type {
@leaders {set defaults_key leaderspec_defaults}
@opts {set defaults_key optspec_defaults}
@values {set defaults_key valspec_defaults}
}
if {[dict exists $opt_override $type]} {
append result \n "$type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]]"
dict set resultdict $type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]]
} else {
append result \n "$type [dict get $specdict leaderspec_defaults]"
dict set resultdict $type [dict get $specdict leaderspec_defaults]
}
}
}
leaders - opts - values {
#pseudo-directives
if {$type in $included_directives} {
foreach m $included_args {
set argspec [dict get $arg_info $m]
if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} {
set argspec [dict remove $argspec -ARGTYPE]
if {[dict exists $opt_override $m]} {
append result \n "$m [dict merge $argspec [dict get $opt_override $m]]"
dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]]
} else {
append result \n "$m $argspec"
dict set resultdict $m $argspec
}
}
}
}
}
default {
}
}
if {$opt_return eq "text"} {
return $result
} else {
return $resultdict
} }
return $result
} }
} }

153
src/bootsupport/modules/punk/path-0.1.0.tm
Unescape View File

@ -20,7 +20,7 @@
#[manpage_begin punkshell_module_punk::path 0 0.1.0] #[manpage_begin punkshell_module_punk::path 0 0.1.0]
#[copyright "2023"] #[copyright "2023"]
#[titledesc {Filesystem path utilities}] [comment {-- Name section and table of contents description --}] #[titledesc {Filesystem path utilities}] [comment {-- Name section and table of contents description --}]
#[moddesc {punk path filesystem utils}] [comment {-- Description at end of page heading --}] #[moddesc {punk path filesystem utils}] [comment {-- Description at end of page heading --}]
#[require punk::path] #[require punk::path]
#[description] #[description]
#[keywords module path filesystem] #[keywords module path filesystem]
@ -104,21 +104,21 @@ namespace eval punk::path {
#*** !doctools #*** !doctools
#[subsection {Namespace punk::path}] #[subsection {Namespace punk::path}]
#[para] Core API functions for punk::path #[para] Core API functions for punk::path
#[list_begin definitions] #[list_begin definitions]
# -- --- # -- ---
#punk::path::normjoin #punk::path::normjoin
# - simplify . and .. segments as far as possible whilst respecting specific types of root. # - simplify . and .. segments as far as possible whilst respecting specific types of root.
# -- --- # -- ---
#a form of file normalize that supports //xxx to be treated as server path names #a form of file normalize that supports //xxx to be treated as server path names
#(ie regardless of unices ignoring (generally) leading double slashes, and regardless of windows volumerelative path syntax) #(ie regardless of unices ignoring (generally) leading double slashes, and regardless of windows volumerelative path syntax)
#(sometimes //server.com used as a short form for urls - which doesn't seem too incompatible with this anyway) #(sometimes //server.com used as a short form for urls - which doesn't seem too incompatible with this anyway)
# -- --- # -- ---
#This is intended to be purely a string analysis - without reference to filesystem volumes or vfs or zipfs mountpoints etc #This is intended to be purely a string analysis - without reference to filesystem volumes or vfs or zipfs mountpoints etc
# #
#TODO - option for caller to provide a -base below which we can't backtrack. #TODO - option for caller to provide a -base below which we can't backtrack.
#This is preferable to setting policy here for example regarding forcing no trackback below //servername/share #This is preferable to setting policy here for example regarding forcing no trackback below //servername/share
#Our default is to allow trackback to: #Our default is to allow trackback to:
# <scheme>://<something> # <scheme>://<something>
# <driveletter>:/ # <driveletter>:/
@ -128,7 +128,7 @@ namespace eval punk::path {
# ./../<repeated> - (track back indefinitely on relpath as we are not resolving to anything physical and can't fully simplify the leading backtracks) # ./../<repeated> - (track back indefinitely on relpath as we are not resolving to anything physical and can't fully simplify the leading backtracks)
# #
#The caller should do the file/vfs operations to determine this - not us. #The caller should do the file/vfs operations to determine this - not us.
# -- --- # -- ---
#simplify path with respect to /./ & /../ elements - independent of platform #simplify path with respect to /./ & /../ elements - independent of platform
#NOTE: "anomalies" in standard tcl processing on windows: #NOTE: "anomalies" in standard tcl processing on windows:
#e.g file normalize {//host} -> c:/host (or e.g d:/host if we happen to be on another volume) #e.g file normalize {//host} -> c:/host (or e.g d:/host if we happen to be on another volume)
@ -148,9 +148,9 @@ namespace eval punk::path {
#known issues: #known issues:
#1) #1)
# normjoin d://a//b//c -> d://a/b/c # normjoin d://a//b//c -> d://a/b/c
# This is because we don't detect specific schemes. ie it's treated the same as https://a/b/c -> https://a/b/c # This is because we don't detect specific schemes. ie it's treated the same as https://a/b/c -> https://a/b/c
# Not considered a problem - just potentially surprising. # Not considered a problem - just potentially surprising.
# To avoid it we would have to enumerate possible schemes. # To avoid it we would have to enumerate possible schemes.
# As it stands a unix system could define a 'scheme' that happens to match windows style driveletters. Consider a 'feature' ? review. # As it stands a unix system could define a 'scheme' that happens to match windows style driveletters. Consider a 'feature' ? review.
# won't fix? # won't fix?
#2) #2)
@ -164,16 +164,16 @@ namespace eval punk::path {
# normjoin ///server/share -> ///server/share # normjoin ///server/share -> ///server/share
#This is effectively an empty servername in the input with 'server' being pushed one level down - and the output is consistent #This is effectively an empty servername in the input with 'server' being pushed one level down - and the output is consistent
# possibly won't fix - review # possibly won't fix - review
#4) inconsistency #4) inconsistency
# we return normalized //server/share for //./UNC/server share # we return normalized //server/share for //./UNC/server share
# but other dos device paths are maintained # but other dos device paths are maintained
# e.g //./c:/etc # e.g //./c:/etc
# This is because such paths could contain alternate segment names (windows shortnames) which we aren't in a position to resolve. # This is because such paths could contain alternate segment names (windows shortnames) which we aren't in a position to resolve.
# caller should # caller should
# #as with 'case' below - caller will need to run a post 'file normalize' # #as with 'case' below - caller will need to run a post 'file normalize'
#5) we don't normalize case like file normalize does on windows platform. #5) we don't normalize case like file normalize does on windows platform.
# This is intentional. It could only be done with reference to underlying filesystem which we don't want here. # This is intentional. It could only be done with reference to underlying filesystem which we don't want here.
# #
# ================ # ================
# #
#relpaths all end up with leading . - while not always the simplest form, this is ok. (helps stop inadvertent conversions to absolutes) #relpaths all end up with leading . - while not always the simplest form, this is ok. (helps stop inadvertent conversions to absolutes)
@ -194,14 +194,14 @@ namespace eval punk::path {
/// { /// {
#if this is effectively //$emptyservername/ #if this is effectively //$emptyservername/
#then for consistency we should trail //<servername with a slash too? #then for consistency we should trail //<servername with a slash too?
#we can't transform to // or / #we can't transform to // or /
return /// return ///
#assert - code below should return /// (empty server prefix) for any number of leading slashes >=3 #assert - code below should return /// (empty server prefix) for any number of leading slashes >=3
#todo - shortcircuit that here? #todo - shortcircuit that here?
} }
} }
# /// # ///
set doubleslash1_posn [string first // $path] set doubleslash1_posn [string first // $path]
# -- --- --- temp warning on windows only - no x-platform difference in result # -- --- --- temp warning on windows only - no x-platform difference in result
#on windows //host is of type volumerelative #on windows //host is of type volumerelative
@ -221,7 +221,7 @@ namespace eval punk::path {
} }
# -- --- --- # -- --- ---
set is_relpath 0 set is_relpath 0
#set path [string map [list \\ /] $path] #set path [string map [list \\ /] $path]
set finalparts [list] set finalparts [list]
@ -264,11 +264,11 @@ namespace eval punk::path {
#normalize by dropping leading slash before split - and then treating first 2 segments as a root #normalize by dropping leading slash before split - and then treating first 2 segments as a root
#set parts [file split [string range $path 1 end]] #set parts [file split [string range $path 1 end]]
set parts [split $path /] set parts [split $path /]
#assert parts here has {} {} as first 2 entries #assert parts here has {} {} as first 2 entries
set rootindex 2 set rootindex 2
#currently prefer can backtrack to the //zipfs:/ scheme (below the mountpoint - to browse other mounts) #currently prefer can backtrack to the //zipfs:/ scheme (below the mountpoint - to browse other mounts)
#alternative handling for //zipfs:/path - don't go below mountpoint #alternative handling for //zipfs:/path - don't go below mountpoint
#but we can't determine just from string if mountpoint is direct subpath or a lower one e.g //zipfs:/arbitraryname/actualmountpoint #but we can't determine just from string if mountpoint is direct subpath or a lower one e.g //zipfs:/arbitraryname/actualmountpoint
#review - more generally //<mountmechanism>:/path ? #review - more generally //<mountmechanism>:/path ?
#todo - make an option for zipfs and others to determine the 'base' #todo - make an option for zipfs and others to determine the 'base'
#if {"zipfs:" eq [lindex $parts 2]} { #if {"zipfs:" eq [lindex $parts 2]} {
@ -281,7 +281,7 @@ namespace eval punk::path {
#set parts [file split $path] #set parts [file split $path]
set parts [::split $path /] set parts [::split $path /]
#e.g /a/b/c -> {} a b c #e.g /a/b/c -> {} a b c
#or relative path a/b/c -> a b c #or relative path a/b/c -> a b c
#or c:/a/b/c -> c: a b c #or c:/a/b/c -> c: a b c
if {[string match *: [lindex $parts 0]]} { if {[string match *: [lindex $parts 0]]} {
if {[lindex $parts 1] eq ""} { if {[lindex $parts 1] eq ""} {
@ -295,9 +295,9 @@ namespace eval punk::path {
} elseif {[lindex $parts 0] ne ""} { } elseif {[lindex $parts 0] ne ""} {
#relpath a/b/c #relpath a/b/c
set parts [linsert $parts 0 .] set parts [linsert $parts 0 .]
set rootindex 0 set rootindex 0
#allow backtracking arbitrarily for leading .. entries - simplify where possible #allow backtracking arbitrarily for leading .. entries - simplify where possible
#also need to stop possible conversion to absolute path #also need to stop possible conversion to absolute path
set is_relpath 1 set is_relpath 1
} }
} }
@ -306,7 +306,7 @@ namespace eval punk::path {
#puts stderr "-->baseparts:$baseparts" #puts stderr "-->baseparts:$baseparts"
#ensure that if our rootindex already spans a dotted segment (after the first one) we remove it #ensure that if our rootindex already spans a dotted segment (after the first one) we remove it
#must maintain initial . for relpaths to stop them converting to absolute via backtrack #must maintain initial . for relpaths to stop them converting to absolute via backtrack
# #
set finalparts [list [lindex $baseparts 0]] set finalparts [list [lindex $baseparts 0]]
foreach b [lrange $baseparts 1 end] { foreach b [lrange $baseparts 1 end] {
if {$b ni {. ..}} { if {$b ni {. ..}} {
@ -333,7 +333,7 @@ namespace eval punk::path {
lappend finalparts $p lappend finalparts $p
} }
} }
incr i incr i
} }
} else { } else {
foreach p [lrange $parts $rootindex+1 end] { foreach p [lrange $parts $rootindex+1 end] {
@ -345,7 +345,7 @@ namespace eval punk::path {
switch -exact -- $p { switch -exact -- $p {
. - "" {} . - "" {}
.. { .. {
lpop finalparts ;#uses punk::lib::compat::lpop if on < 8.7 lpop finalparts ;#uses punk::lib::compat::lpop if on < 8.7
} }
default { default {
lappend finalparts $p lappend finalparts $p
@ -403,16 +403,16 @@ namespace eval punk::path {
} }
#x-platform - punk::path::pathtype - can be used in safe interps - different concept of pathtypes to 'file pathtype' #x-platform - punk::path::pathtype - can be used in safe interps - different concept of pathtypes to 'file pathtype'
# - no volumerelative # - no volumerelative
# - no lookup of file volumes (volume is a windows concept - but with //zipfs:/ somewhat applicable to other platforms) # - no lookup of file volumes (volume is a windows concept - but with //zipfs:/ somewhat applicable to other platforms)
# - /* as absolute (covers also //zipfs:/ (volume), //server , //./etc , //./UNC) # - /* as absolute (covers also //zipfs:/ (volume), //server , //./etc , //./UNC)
# - xxx:// as absolute (scheme) # - xxx:// as absolute (scheme)
# - xxx:/ or x:/ as absolute # - xxx:/ or x:/ as absolute
# - x: xxx: -> as absolute (volume-basic or volume-extended) # - x: xxx: -> as absolute (volume-basic or volume-extended)
#note also on windows - legacy name for COM devices #note also on windows - legacy name for COM devices
# COM1 = COM1: # COM1 = COM1:
# //./COM1 ?? review # //./COM1 ?? review
proc pathtype {str} { proc pathtype {str} {
@ -425,7 +425,7 @@ namespace eval punk::path {
return absolute return absolute
} }
#only firstsegment with single colon at last position (after some non empty string) counts as volume or scheme - review #only firstsegment with single colon at last position (after some non empty string) counts as volume or scheme - review
#e.g a:b:/.. or a::/.. or :/.. is not treated as volume/scheme whereas ab:/ is. #e.g a:b:/.. or a::/.. or :/.. is not treated as volume/scheme whereas ab:/ is.
set firstslash [string first / $str] set firstslash [string first / $str]
if {$firstslash == -1} { if {$firstslash == -1} {
@ -434,9 +434,9 @@ namespace eval punk::path {
set firstsegment [string range $str 0 $firstslash-1] set firstsegment [string range $str 0 $firstslash-1]
} }
if {[set firstc [string first : $firstsegment]] > 0} { if {[set firstc [string first : $firstsegment]] > 0} {
set lhs_firstsegment [string range $firstsegment 0 $firstc-1] set lhs_firstsegment [string range $firstsegment 0 $firstc-1]
set rhs_firstsegment [string range $firstsegment $firstc+1 end] ;#exclude a:b/ etc set rhs_firstsegment [string range $firstsegment $firstc+1 end] ;#exclude a:b/ etc
if {$rhs_firstsegment eq ""} { if {$rhs_firstsegment eq ""} {
set rhs_entire_path [string range $str $firstc+1 end] set rhs_entire_path [string range $str $firstc+1 end]
#assert lhs_firstsegment not empty since firstc > 0 #assert lhs_firstsegment not empty since firstc > 0
#count following / sequence #count following / sequence
@ -466,7 +466,7 @@ namespace eval punk::path {
} }
} }
} }
#assert first element of any return has been absolute or relative #assert first element of any return has been absolute or relative
return relative return relative
} }
@ -489,7 +489,7 @@ namespace eval punk::path {
} }
return $str return $str
} }
#purely string based - no reference to filesystem knowledge #purely string based - no reference to filesystem knowledge
#unix-style forward slash only #unix-style forward slash only
proc plainjoin {args} { proc plainjoin {args} {
set args [lmap a $args {string map "\\\\ /" $a}] set args [lmap a $args {string map "\\\\ /" $a}]
@ -499,12 +499,12 @@ namespace eval punk::path {
set out "" set out ""
foreach a $args { foreach a $args {
if {![string length $out]} { if {![string length $out]} {
append out [plain $a] append out [plain $a]
} else { } else {
set a [plain $a] set a [plain $a]
if {[string map {/ ""} $out] eq ""} { if {[string map {/ ""} $out] eq ""} {
set out [string range $out 0 end-1] set out [string range $out 0 end-1]
} }
if {[string map {/ ""} $a] eq ""} { if {[string map {/ ""} $a] eq ""} {
#all / segment #all / segment
@ -512,16 +512,16 @@ namespace eval punk::path {
} else { } else {
if {[string length $a] > 2 && [string match "./*" $a]} { if {[string length $a] > 2 && [string match "./*" $a]} {
set a [string range $a 2 end] set a [string range $a 2 end]
} }
if {[string index $out end] eq "/"} { if {[string index $out end] eq "/"} {
append out $a append out $a
} else { } else {
append out / $a append out / $a
} }
} }
} }
} }
return $out return $out
} }
proc plainjoin1 {args} { proc plainjoin1 {args} {
if {[llength $args] == 1} { if {[llength $args] == 1} {
@ -530,9 +530,9 @@ namespace eval punk::path {
set out [trim_final_slash [lindex $args 0]] set out [trim_final_slash [lindex $args 0]]
foreach a [lrange $args 1 end] { foreach a [lrange $args 1 end] {
set a [trim_final_slash $a] set a [trim_final_slash $a]
append out / $a append out / $a
} }
return $out return $out
} }
#intention? #intention?
@ -554,13 +554,13 @@ namespace eval punk::path {
#*** !doctools #*** !doctools
#[call [fun pathglob_as_re] [arg pathglob]] #[call [fun pathglob_as_re] [arg pathglob]]
#[para] Returns a regular expression for matching a path to a glob pattern which can contain glob chars *|? in any segment of the path structure #[para] Returns a regular expression for matching a path to a glob pattern which can contain glob chars *|? in any segment of the path structure
#[para] ** matches any number of subdirectories. #[para] ** matches any number of subdirectories.
#[para] e.g /etc/**/*.txt will match any .txt files at any depth below /etc (except directly within /etc itself) #[para] e.g /etc/**/*.txt will match any .txt files at any depth below /etc (except directly within /etc itself)
#[para] e.g /etc/**.txt will match any .txt files at any depth below /etc #[para] e.g /etc/**.txt will match any .txt files at any depth below /etc
#[para] any segment that does not contain ** must match exactly one segment in the path #[para] any segment that does not contain ** must match exactly one segment in the path
#[para] e.g the glob /etc/*/*.doc - will match any .doc files that are exactly one tree level below /etc #[para] e.g the glob /etc/*/*.doc - will match any .doc files that are exactly one tree level below /etc
#[para] The pathglob doesn't have to contain glob characters, in which case the returned regex will match the pathglob exactly as specified. #[para] The pathglob doesn't have to contain glob characters, in which case the returned regex will match the pathglob exactly as specified.
#[para] Regular expression syntax is deliberateley not supported within the pathglob string so that supplied regex characters will be treated as literals #[para] Regular expression syntax is deliberateley not supported within the pathglob string so that supplied regex characters will be treated as literals
#todo - consider whether a way to escape the glob chars ? * is practical - to allow literals ? * #todo - consider whether a way to escape the glob chars ? * is practical - to allow literals ? *
@ -572,9 +572,9 @@ namespace eval punk::path {
} }
switch -- $seg { switch -- $seg {
* {lappend pats {[^/]*}} * {lappend pats {[^/]*}}
** {lappend pats {.*}} ** {lappend pats {.*}}
default { default {
set seg [string map [list {^ {\^} $ {\$} [} {\[} ( {\(} \{ \\\{ \\ {\\}] $seg] ;#treat regex characters in the input as literals set seg [string map [list {^ {\^} $ {\$} [} {\[} ( {\(} \{ \\\{ \\ {\\}] $seg] ;#treat regex characters in the input as literals
#set seg [string map [list . {[.]}] $seg] #set seg [string map [list . {[.]}] $seg]
set seg [string map {. [.]} $seg] set seg [string map {. [.]} $seg]
if {[regexp {[*?]} $seg]} { if {[regexp {[*?]} $seg]} {
@ -614,14 +614,14 @@ namespace eval punk::path {
} }
} }
} }
# -- --- --- --- --- --- # -- --- --- --- --- ---
set opt_nocase [dict get $opts -nocase] set opt_nocase [dict get $opts -nocase]
set explicit_nocase 1 ;#default to disprove set explicit_nocase 1 ;#default to disprove
if {$opt_nocase eq "\uFFFF"} { if {$opt_nocase eq "\uFFFF"} {
set opt_nocase 0 set opt_nocase 0
set explicit_nocase 0 set explicit_nocase 0
} }
# -- --- --- --- --- --- # -- --- --- --- --- ---
if {$opt_nocase} { if {$opt_nocase} {
return [regexp -nocase [pathglob_as_re $pathglob] $path] return [regexp -nocase [pathglob_as_re $pathglob] $path]
} else { } else {
@ -651,33 +651,33 @@ namespace eval punk::path {
-call-depth-internal -default 0 -type integer -call-depth-internal -default 0 -type integer
-antiglob_paths -default {} -help\ -antiglob_paths -default {} -help\
"list of path patterns to exclude "list of path patterns to exclude
may include * and ** path segments e.g may include * and ** path segments e.g
/usr/** (exlude subfolders based at /usr but not /usr/** (exlude subfolders based at /usr but not
files within /usr itself) files within /usr itself)
**/_aside (exlude files where _aside is last segment) **/_aside (exlude files where _aside is last segment)
**/_aside/* (exclude folders one below an _aside folder) **/_aside/* (exclude folders one below an _aside folder)
**/_aside/** (exclude all folders with _aside as a segment)" **/_aside/** (exclude all folders with _aside as a segment)"
@values -min 0 -max -1 -optional 1 -type string @values -min 0 -max -1 -optional 1 -type string
tailglobs -default * -multiple 1 -help\ tailglobs -default * -multiple 1 -help\
"Patterns to match against filename portion (last segment) of each file path "Patterns to match against filename portion (last segment) of each file path
within the directory tree being searched." within the directory tree being searched."
} }
#todo - implement treefiles which acts like dirfiles but allows path globbing in the same way as punk::ns::ns/ #todo - implement treefiles which acts like dirfiles but allows path globbing in the same way as punk::ns::ns/
#then review if treefiles can replace dirfiles or if both should exist (dirfiles can have literal glob chars in path segments - but that is a rare usecase) #then review if treefiles can replace dirfiles or if both should exist (dirfiles can have literal glob chars in path segments - but that is a rare usecase)
proc treefilenames {args} { proc treefilenames {args} {
#*** !doctools #*** !doctools
#[call [fun treefilenames] [opt {option value...}] [opt {globpattern...}]] #[call [fun treefilenames] [opt {option value...}] [opt {globpattern...}]]
#[para]basic (glob based) list of filenames matching each pattern in tailglobs - recursive #[para]basic (glob based) list of filenames matching each pattern in tailglobs - recursive
#[para] options: #[para] options:
#[para] [opt -dir] <path> #[para] [opt -dir] <path>
#[para] defaults to [lb]pwd[rb] - base path for tree to search #[para] defaults to [lb]pwd[rb] - base path for tree to search
#[para] [opt -antiglob_paths] <list> #[para] [opt -antiglob_paths] <list>
#[para] list of path patterns to exclude - may include * and ** path segments e.g /usr/** #[para] list of path patterns to exclude - may include * and ** path segments e.g /usr/**
#[para]no natsorting - so order is dependent on filesystem #[para]no natsorting - so order is dependent on filesystem
set argd [punk::args::parse $args withid ::punk::path::treefilenames] set argd [punk::args::parse $args withid ::punk::path::treefilenames]
lassign [dict values $argd] leaders opts values received lassign [dict values $argd] leaders opts values received
set tailglobs [dict get $values tailglobs] set tailglobs [dict get $values tailglobs]
# -- --- --- --- --- --- --- # -- --- --- --- --- --- ---
set opt_antiglob_paths [dict get $opts -antiglob_paths] set opt_antiglob_paths [dict get $opts -antiglob_paths]
@ -694,7 +694,7 @@ namespace eval punk::path {
set opt_dir [dict get $opts -directory] set opt_dir [dict get $opts -directory]
} }
if {![file isdirectory $opt_dir]} { if {![file isdirectory $opt_dir]} {
return [list] return [list]
} }
} else { } else {
#assume/require to exist in any recursive call #assume/require to exist in any recursive call
@ -713,15 +713,26 @@ namespace eval punk::path {
} }
#todo - account for vfs where matched path could appear to be a directory but is mounted so could be a desired match? #todo - account for vfs where matched path could appear to be a directory but is mounted so could be a desired match?
set dirfiles [lsort [glob -nocomplain -dir $opt_dir -type f {*}$tailglobs]] if {[catch {glob -nocomplain -dir $opt_dir -type f {*}$tailglobs} matches]} {
#we can get for example a permissions error
puts stderr "treefilenames error while listing files in dir $opt_dir\n $matches"
set dirfiles [list]
} else {
set dirfiles [lsort $matches]
}
lappend files {*}$dirfiles lappend files {*}$dirfiles
set dirdirs [glob -nocomplain -dir $opt_dir -type d *] if {[catch {glob -nocomplain -dir $opt_dir -type d *} dirdirs]} {
puts stderr "treefilenames error while listing subdirs in dir $opt_dir\n $dirdirs"
set dirdirs [list]
}
foreach dir $dirdirs { foreach dir $dirdirs {
set skip 0 set skip 0
foreach anti $opt_antiglob_paths { foreach anti $opt_antiglob_paths {
if {[globmatchpath $anti $dir]} { if {[globmatchpath $anti $dir]} {
set skip 1 set skip 1
break break
} }
} }
if {$skip} { if {$skip} {
@ -743,8 +754,8 @@ namespace eval punk::path {
#[item] #[item]
#[para] Arguments: #[para] Arguments:
# [list_begin arguments] # [list_begin arguments]
# [arg_def string reference] The path from which the relative path to location is determined. # [arg_def string reference] The path from which the relative path to location is determined.
# [arg_def string location] The location path which may be above or below the reference path # [arg_def string location] The location path which may be above or below the reference path
# [list_end] # [list_end]
#[item] #[item]
#[para] Results: #[para] Results:
@ -753,7 +764,7 @@ namespace eval punk::path {
#[item] #[item]
#[para] Notes: #[para] Notes:
#[para] Both paths must be the same type - ie both absolute or both relative #[para] Both paths must be the same type - ie both absolute or both relative
#[para] Case sensitive. ie punk::path::relative /etc /etC #[para] Case sensitive. ie punk::path::relative /etc /etC
# will return ../etC # will return ../etC
#[para] On windows, the drive-letter component (only) is not case sensitive #[para] On windows, the drive-letter component (only) is not case sensitive
#[example_begin] #[example_begin]
@ -774,7 +785,7 @@ namespace eval punk::path {
#[example_begin] #[example_begin]
# P% punk::path::relative /usr/local/etc/ /usr/local/etc/somewhere/below # P% punk::path::relative /usr/local/etc/ /usr/local/etc/somewhere/below
# - somewhere/below # - somewhere/below
# P% punk::path::relative /usr/local/etc/somewhere /usr/local/lib/here # P% punk::path::relative /usr/local/etc/somewhere /usr/local/lib/here
# - ../../lib/here # - ../../lib/here
#[example_end] #[example_end]
#[list_end] #[list_end]
@ -791,7 +802,7 @@ namespace eval punk::path {
#avoid normalizing if possible (file normalize *very* expensive on windows) #avoid normalizing if possible (file normalize *very* expensive on windows)
set do_normalize 0 set do_normalize 0
if {[file pathtype $reference] eq "relative"} { if {[file pathtype $reference] eq "relative"} {
#if reference is relative so is location #if reference is relative so is location
if {[regexp {[.]{2}} [list $reference $location]]} { if {[regexp {[.]{2}} [list $reference $location]]} {
set do_normalize 1 set do_normalize 1
} }
@ -857,7 +868,7 @@ namespace eval punk::path::lib {
namespace path [namespace parent] namespace path [namespace parent]
#*** !doctools #*** !doctools
#[subsection {Namespace punk::path::lib}] #[subsection {Namespace punk::path::lib}]
#[para] Secondary functions that are part of the API #[para] Secondary functions that are part of the API
#[list_begin definitions] #[list_begin definitions]
@ -877,17 +888,17 @@ namespace eval punk::path::lib {
namespace eval punk::path::system { namespace eval punk::path::system {
#*** !doctools #*** !doctools
#[subsection {Namespace punk::path::system}] #[subsection {Namespace punk::path::system}]
#[para] Internal functions that are not part of the API #[para] Internal functions that are not part of the API
} }
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready ## Ready
package provide punk::path [namespace eval punk::path { package provide punk::path [namespace eval punk::path {
variable pkg punk::path variable pkg punk::path
variable version variable version
set version 0.1.0 set version 0.1.0
}] }]
return return

31
src/bootsupport/modules/textblock-0.1.3.tm
Unescape View File

@ -5974,13 +5974,40 @@ tcl::namespace::eval textblock {
[>punk . rhs]\ [>punk . rhs]\
[punk::lib::list_as_lines -- [lrepeat 8 " | "]] [punk::lib::list_as_lines -- [lrepeat 8 " | "]]
} }
punk::args::define [punk::lib::tstr -return string {
@id -id ::textblock::table
@cmd -name "textblock::table" -help\
"A wrapper for creating a textblock::class::table
NOTE: more options available - argument definition
is incomplete"
@opts
-return -choices {table tableobject}
-rows -type list -default "" -help\
"A list of lists.
Each toplevel element represents a row.
The number of elements in each row must
be the same.
e.g for 2 rows and 3 columns:
table -rows {{r0c0 r0c1 r0c2} {r1c0 r1c1 r1c2}}
"
-headers -type list -default "" -help\
"This is a simplified form where each column
has a single header row.
Each element in this list goes into the top
header row for a column.
More complex header arrangements where each
column has multiple headers can be made
by using -return tableobject and calling
$tableobj configure_column <idx> -headers"
}]
proc table {args} { proc table {args} {
#todo - use punk::args #todo - use punk::args
upvar ::textblock::class::opts_table_defaults toptdefaults upvar ::textblock::class::opts_table_defaults toptdefaults
set defaults [tcl::dict::create\ set defaults [tcl::dict::create\
-rows [list]\ -rows [list]\
-headers [list]\ -headers [list]\
-return string\ -return table\
] ]
@ -6017,7 +6044,7 @@ tcl::namespace::eval textblock {
if {$opt_return eq "string"} { if {$opt_return eq "table"} {
set result [$t print] set result [$t print]
$t destroy $t destroy
return $result return $result

5566
src/bootsupport/modules/tomlish-1.1.2.tm
View File

File diff suppressed because it is too large Load Diff

326
src/modules/punk/args-999999.0a1.0.tm
Unescape View File

@ -331,26 +331,26 @@ tcl::namespace::eval punk::args {
parsing and help display. parsing and help display.
directives include: directives include:
%B%@id%N% ?opt val...? %B%@id%N% ?opt val...?
options: -id <str> spec-options: -id <str>
%B%@cmd%N% ?opt val...? %B%@cmd%N% ?opt val...?
options: -name <str> -help <str> spec-options: -name <str> -help <str>
%B%@leaders%N% ?opt val...? %B%@leaders%N% ?opt val...?
options: -min <int> -max <int> spec-options: -min <int> -max <int>
(used for leading args that come before switches/opts) (used for leading args that come before switches/opts)
%B%@opts%N% ?opt val...? %B%@opts%N% ?opt val...?
options: -any <bool> spec-options: -any <bool>
%B%@values%N% ?opt val...? %B%@values%N% ?opt val...?
options: -min <int> -max <int> spec-options: -min <int> -max <int>
(used for trailing args that come after switches/opts) (used for trailing args that come after switches/opts)
%B%@argdisplay%N% ?opt val...? %B%@argdisplay%N% ?opt val...?
options: -header <str> (text for header row of table) spec-options: -header <str> (text for header row of table)
-body <str> (text to replace autogenerated arg info) -body <str> (text to replace autogenerated arg info)
%B%@doc%N% ?opt val...? %B%@doc%N% ?opt val...?
options: -name <str> -url <str> spec-options: -name <str> -url <str>
%B%@seealso%N% ?opt val...? %B%@seealso%N% ?opt val...?
options: -name <str> -url <str> (for footer - unimplemented) spec-options: -name <str> -url <str> (for footer - unimplemented)
Some other options normally present on custom arguments are available Some other spec-options normally present on custom arguments are available
to use with the @leaders @opts @values directives to set defaults to use with the @leaders @opts @values directives to set defaults
for subsequent lines that represent your custom arguments. for subsequent lines that represent your custom arguments.
These directives should occur in exactly this order - but can be These directives should occur in exactly this order - but can be
@ -361,7 +361,12 @@ tcl::namespace::eval punk::args {
or using the i <cmd>.. function - an @id with -id <value> is needed. or using the i <cmd>.. function - an @id with -id <value> is needed.
All directives can be omitted, in which case every line represents All directives can be omitted, in which case every line represents
a custom value or option. a custom leader, value or option.
All will be leaders by default if no options defined.
If options are defined (by naming with leading dash, or explicitly
specifying @opts) then the definitions prior to the options will be
categorised as leaders, and those following the options will be
categorised as values.
Custom arguments are defined by using any word at the start of a Custom arguments are defined by using any word at the start of a
line that doesn't begin with @ or - line that doesn't begin with @ or -
@ -369,7 +374,7 @@ tcl::namespace::eval punk::args {
that @@somearg becomes an argument named @somearg) that @@somearg becomes an argument named @somearg)
custom leading args, switches/options (names starting with -) custom leading args, switches/options (names starting with -)
and trailing values also take options: and trailing values also take spec-options:
-type <typename> -type <typename>
defaults to string. If no other restrictions defaults to string. If no other restrictions
@ -397,12 +402,22 @@ tcl::namespace::eval punk::args {
-optional <boolean> -optional <boolean>
(defaults to true for flags/switches false otherwise) (defaults to true for flags/switches false otherwise)
For non flag/switch arguments - all arguments with
-optional true must sit consecutively within their group.
ie all optional leader arguments must be together, and all
optional value arguments must be together. Furthermore,
specifying both optional leaders and optional values will
often lead to ambiguous parsing results. Currently, all
optional non-flg/switch arguments should be either at the
trailing end of leaders or the trailing end of values.
Further unambiguous arrangements of optional args may be
made in future - but are currently considered 'unsupported'
-default <value> -default <value>
-multiple <bool> (for leaders & values defines whether -multiple <bool> (for leaders & values defines whether
subsequent received values are stored agains the same subsequent received values are stored against the same
argument name - only applies to final leader or value) argument name - only applies to final leader OR final value)
(for options/flags this allows the opt-val pair or solo (for options/flags this allows the opt-val pair or solo
flag to appear multiple times - no necessarily contiguously) flag to appear multiple times - not necessarily contiguously)
-choices {<choicelist>} -choices {<choicelist>}
A list of allowable values for an argument. A list of allowable values for an argument.
The -default value doesn't have to be in the list. The -default value doesn't have to be in the list.
@ -438,7 +453,7 @@ tcl::namespace::eval punk::args {
Max of -1 represents no upper limit. Max of -1 represents no upper limit.
If <range> allows more than one choice the value is a list If <range> allows more than one choice the value is a list
consisting of items in the choices made available through consisting of items in the choices made available through
entries in -choices/-choicegrups. entries in -choices/-choicegroups.
-minsize (type dependant) -minsize (type dependant)
-maxsize (type dependant) -maxsize (type dependant)
-range (type dependant) -range (type dependant)
@ -1667,6 +1682,7 @@ tcl::namespace::eval punk::args {
" "
@leaders -min 0 -max 0 @leaders -min 0 -max 0
@opts @opts
-return -default text -choices {text dict}
-form -default 0 -help\ -form -default 0 -help\
"Ordinal index or name of command form" "Ordinal index or name of command form"
@ -1694,7 +1710,7 @@ tcl::namespace::eval punk::args {
(directives are lines beginning with (directives are lines beginning with
@ e.g @id, @cmd etc) @ e.g @id, @cmd etc)
if -type is @leaders,@opts or @values matches from that type if -type is leaders,opts or values matches from that type
will be returned. will be returned.
if -type is another directive such as @id, @doc etc the if -type is another directive such as @id, @doc etc the
@ -1706,8 +1722,10 @@ tcl::namespace::eval punk::args {
proc resolved_def {args} { proc resolved_def {args} {
#not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only.
set opts [dict create\ set opts [dict create\
-types {}\ -return text\
-types {}\
-form 0\ -form 0\
-antiglobs {}\ -antiglobs {}\
-override {}\ -override {}\
@ -1743,7 +1761,7 @@ tcl::namespace::eval punk::args {
} }
dict for {k v} $opts { dict for {k v} $opts {
switch -- $k { switch -- $k {
-form - -types - -antiglobs - -override {} -return - -form - -types - -antiglobs - -override {}
default { default {
punk::args::parse $args withid ::punk::args::resolved_def punk::args::parse $args withid ::punk::args::resolved_def
return return
@ -1764,163 +1782,185 @@ tcl::namespace::eval punk::args {
variable id_cache_rawdef variable id_cache_rawdef
set realid [real_id $id] set realid [real_id $id]
if {$realid eq ""} {
return
}
if {$realid ne ""} { set deflist [tcl::dict::get $id_cache_rawdef $realid]
set deflist [tcl::dict::get $id_cache_rawdef $realid] set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]]
set result ""
set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]]
set opt_form [dict get $opts -form] set opt_form [dict get $opts -form]
if {[string is integer -strict $opt_form]} { if {[string is integer -strict $opt_form]} {
set formname [lindex [dict get $specdict form_names] $opt_form] set formname [lindex [dict get $specdict form_names] $opt_form]
} else { } else {
set formname $opt_form set formname $opt_form
} }
set opt_override [dict get $opts -override] set opt_override [dict get $opts -override]
set opt_return [dict get $opts -return]
#set arg_info [dict get $specdict ARG_INFO]
set arg_info [dict get $specdict FORMS $formname ARG_INFO] #set arg_info [dict get $specdict ARG_INFO]
set argtypes [dict create leaders leader opts option values value] set arg_info [dict get $specdict FORMS $formname ARG_INFO]
set argtypes [dict create leaders leader opts option values value]
set opt_antiglobs [dict get $opts -antiglobs]
set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] set opt_antiglobs [dict get $opts -antiglobs]
set suppressed_directives [list] set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *]
set suppressed_args [list] set suppressed_directives [list]
foreach ag $opt_antiglobs { set suppressed_args [list]
foreach d $directives { foreach ag $opt_antiglobs {
if {[string match $ag $d]} { foreach d $directives {
lappend suppressed_directives $d if {[string match $ag $d]} {
} lappend suppressed_directives $d
} }
foreach argname [dict keys $arg_info] { }
if {[string match $ag $argname]} { foreach argname [dict keys $arg_info] {
lappend suppressed_args $argname if {[string match $ag $argname]} {
} lappend suppressed_args $argname
} }
} }
set suppressed_directives [lsort -unique $suppressed_directives] }
set suppressed_args [lsort -unique $suppressed_args] set suppressed_directives [lsort -unique $suppressed_directives]
set suppressed_args [lsort -unique $suppressed_args]
set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives]
set globbed [list] set globbed [list]
foreach pat $patterns { foreach pat $patterns {
set matches [dict keys $arg_info $pat] set matches [dict keys $arg_info $pat]
lappend globbed {*}$matches lappend globbed {*}$matches
} }
set globbed [lsort -unique $globbed] set globbed [lsort -unique $globbed]
set included_args [punk::args::system::punklib_ldiff $globbed $suppressed_args] set included_args [punk::args::system::punklib_ldiff $globbed $suppressed_args]
foreach type $typelist {
switch -exact -- $type {
* {
if {"@id" in $included_directives} {
if {[dict exists $opt_override @id]} {
append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]"
} else {
append result \n "@id -id [dict get $specdict id]"
}
}
foreach directive {@package @cmd @doc @seealso @argdisplay} {
set dshort [string range $directive 1 end]
if {"$directive" in $included_directives} {
if {[dict exists $opt_override $directive]} {
append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]"
} else {
append result \n "$directive [dict get $specdict ${dshort}_info]"
}
}
}
#output ordered by leader, option, value
foreach pseudodirective {leaders opts values} tp {leader option value} {
set directive "@$pseudodirective"
switch -- $directive {
@leaders {set defaults_key leaderspec_defaults}
@opts {set defaults_key optspec_defaults}
@values {set defaults_key valspec_defaults}
}
if {"$directive" in $included_directives} {
if {[dict exists $opt_override "$directive"]} {
append result \n "$directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]"
} else {
append result \n "$directive [dict get $specdict $defaults_key]"
}
}
if {$pseudodirective in $included_directives} { set result ""
foreach m $included_args { set resultdict [dict create]
set argspec [dict get $arg_info $m] foreach type $typelist {
if {[dict get $argspec -ARGTYPE] eq $tp} { switch -exact -- $type {
set argspec [dict remove $argspec -ARGTYPE] * {
if {[dict exists $opt_override $m]} { if {"@id" in $included_directives} {
append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" if {[dict exists $opt_override @id]} {
} else { append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]"
append result \n "$m $argspec" dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]
} } else {
} append result \n "@id -id [dict get $specdict id]"
} dict set resultdict @id [list -id [dict get $specdict id]]
}
} }
} }
@id { foreach directive {@package @cmd @doc @seealso @argdisplay} {
if {"@id" in $included_directives} { set dshort [string range $directive 1 end]
#only a single id record can exist if {"$directive" in $included_directives} {
if {[dict exists $opt_override @id]} { if {[dict exists $opt_override $directive]} {
append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]"
dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]
} else { } else {
append result \n "@id -id [dict get $specdict id]" append result \n "$directive [dict get $specdict ${dshort}_info]"
dict set resultdict $directive [dict get $specdict ${dshort}_info]
} }
} }
} }
@package - @cmd - @doc - @seealso - @argdisplay { #output ordered by leader, option, value
if {"$type" in $included_directives} { foreach pseudodirective {leaders opts values} tp {leader option value} {
set tp [string range $type 1 end] ;# @package -> package set directive "@$pseudodirective"
if {[dict exists $opt_override $type]} { switch -- $directive {
append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" @leaders {set defaults_key leaderspec_defaults}
} else { @opts {set defaults_key optspec_defaults}
append result \n "$type [dict get $specdict ${tp}_info]" @values {set defaults_key valspec_defaults}
}
} }
}
@leaders - @opts - @values { if {"$directive" in $included_directives} {
#these are the active defaults for further arguments if {[dict exists $opt_override "$directive"]} {
if {"$type" in $included_directives} { append result \n "$directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]"
switch -- $type { dict set resultdict $directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]
@leaders {set defaults_key leaderspec_defaults}
@opts {set defaults_key optspec_defaults}
@values {set defaults_key valspec_defaults}
}
if {[dict exists $opt_override $type]} {
append result \n "$type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]]"
} else { } else {
append result \n "$type [dict get $specdict leaderspec_defaults]" append result \n "$directive [dict get $specdict $defaults_key]"
dict set resultdict $directive [dict get $specdict $defaults_key]
} }
} }
}
leaders - opts - values { if {$pseudodirective in $included_directives} {
#pseudo-directives
if {$type in $included_directives} {
foreach m $included_args { foreach m $included_args {
set argspec [dict get $arg_info $m] set argspec [dict get $arg_info $m]
if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { if {[dict get $argspec -ARGTYPE] eq $tp} {
set argspec [dict remove $argspec -ARGTYPE] set argspec [dict remove $argspec -ARGTYPE]
if {[dict exists $opt_override $m]} { if {[dict exists $opt_override $m]} {
append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" append result \n "$m [dict merge $argspec [dict get $opt_override $m]]"
dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]]
} else { } else {
append result \n "$m $argspec" append result \n "$m $argspec"
dict set resultdict $m $argspec
} }
} }
} }
} }
} }
default {
}
@id {
if {"@id" in $included_directives} {
#only a single id record can exist
if {[dict exists $opt_override @id]} {
append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]"
dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]
} else {
append result \n "@id -id [dict get $specdict id]"
dict set resultdict @id [list -id [dict get $specdict id]]
}
} }
} }
@package - @cmd - @doc - @seealso - @argdisplay {
if {"$type" in $included_directives} {
set tp [string range $type 1 end] ;# @package -> package
if {[dict exists $opt_override $type]} {
append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]"
dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]
} else {
append result \n "$type [dict get $specdict ${tp}_info]"
dict set resultdict $type [dict get $specdict ${tp}_info]
}
}
}
@leaders - @opts - @values {
#these are the active defaults for further arguments
if {"$type" in $included_directives} {
switch -- $type {
@leaders {set defaults_key leaderspec_defaults}
@opts {set defaults_key optspec_defaults}
@values {set defaults_key valspec_defaults}
}
if {[dict exists $opt_override $type]} {
append result \n "$type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]]"
dict set resultdict $type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]]
} else {
append result \n "$type [dict get $specdict leaderspec_defaults]"
dict set resultdict $type [dict get $specdict leaderspec_defaults]
}
}
}
leaders - opts - values {
#pseudo-directives
if {$type in $included_directives} {
foreach m $included_args {
set argspec [dict get $arg_info $m]
if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} {
set argspec [dict remove $argspec -ARGTYPE]
if {[dict exists $opt_override $m]} {
append result \n "$m [dict merge $argspec [dict get $opt_override $m]]"
dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]]
} else {
append result \n "$m $argspec"
dict set resultdict $m $argspec
}
}
}
}
}
default {
}
}
if {$opt_return eq "text"} {
return $result
} else {
return $resultdict
} }
return $result
} }
} }

1298
src/modules/punk/imap4-999999.0a1.0.tm
View File

File diff suppressed because it is too large Load Diff

1228
src/modules/punk/netbox-999999.0a1.0.tm
View File

File diff suppressed because it is too large Load Diff

3
src/modules/punk/netbox-buildversion.txt
Unescape View File

@ -0,0 +1,3 @@
0.1.0
#First line must be a semantic version number
#all other lines are ignored.

153
src/modules/punk/path-999999.0a1.0.tm
Unescape View File

@ -20,7 +20,7 @@
#[manpage_begin punkshell_module_punk::path 0 999999.0a1.0] #[manpage_begin punkshell_module_punk::path 0 999999.0a1.0]
#[copyright "2023"] #[copyright "2023"]
#[titledesc {Filesystem path utilities}] [comment {-- Name section and table of contents description --}] #[titledesc {Filesystem path utilities}] [comment {-- Name section and table of contents description --}]
#[moddesc {punk path filesystem utils}] [comment {-- Description at end of page heading --}] #[moddesc {punk path filesystem utils}] [comment {-- Description at end of page heading --}]
#[require punk::path] #[require punk::path]
#[description] #[description]
#[keywords module path filesystem] #[keywords module path filesystem]
@ -104,21 +104,21 @@ namespace eval punk::path {
#*** !doctools #*** !doctools
#[subsection {Namespace punk::path}] #[subsection {Namespace punk::path}]
#[para] Core API functions for punk::path #[para] Core API functions for punk::path
#[list_begin definitions] #[list_begin definitions]
# -- --- # -- ---
#punk::path::normjoin #punk::path::normjoin
# - simplify . and .. segments as far as possible whilst respecting specific types of root. # - simplify . and .. segments as far as possible whilst respecting specific types of root.
# -- --- # -- ---
#a form of file normalize that supports //xxx to be treated as server path names #a form of file normalize that supports //xxx to be treated as server path names
#(ie regardless of unices ignoring (generally) leading double slashes, and regardless of windows volumerelative path syntax) #(ie regardless of unices ignoring (generally) leading double slashes, and regardless of windows volumerelative path syntax)
#(sometimes //server.com used as a short form for urls - which doesn't seem too incompatible with this anyway) #(sometimes //server.com used as a short form for urls - which doesn't seem too incompatible with this anyway)
# -- --- # -- ---
#This is intended to be purely a string analysis - without reference to filesystem volumes or vfs or zipfs mountpoints etc #This is intended to be purely a string analysis - without reference to filesystem volumes or vfs or zipfs mountpoints etc
# #
#TODO - option for caller to provide a -base below which we can't backtrack. #TODO - option for caller to provide a -base below which we can't backtrack.
#This is preferable to setting policy here for example regarding forcing no trackback below //servername/share #This is preferable to setting policy here for example regarding forcing no trackback below //servername/share
#Our default is to allow trackback to: #Our default is to allow trackback to:
# <scheme>://<something> # <scheme>://<something>
# <driveletter>:/ # <driveletter>:/
@ -128,7 +128,7 @@ namespace eval punk::path {
# ./../<repeated> - (track back indefinitely on relpath as we are not resolving to anything physical and can't fully simplify the leading backtracks) # ./../<repeated> - (track back indefinitely on relpath as we are not resolving to anything physical and can't fully simplify the leading backtracks)
# #
#The caller should do the file/vfs operations to determine this - not us. #The caller should do the file/vfs operations to determine this - not us.
# -- --- # -- ---
#simplify path with respect to /./ & /../ elements - independent of platform #simplify path with respect to /./ & /../ elements - independent of platform
#NOTE: "anomalies" in standard tcl processing on windows: #NOTE: "anomalies" in standard tcl processing on windows:
#e.g file normalize {//host} -> c:/host (or e.g d:/host if we happen to be on another volume) #e.g file normalize {//host} -> c:/host (or e.g d:/host if we happen to be on another volume)
@ -148,9 +148,9 @@ namespace eval punk::path {
#known issues: #known issues:
#1) #1)
# normjoin d://a//b//c -> d://a/b/c # normjoin d://a//b//c -> d://a/b/c
# This is because we don't detect specific schemes. ie it's treated the same as https://a/b/c -> https://a/b/c # This is because we don't detect specific schemes. ie it's treated the same as https://a/b/c -> https://a/b/c
# Not considered a problem - just potentially surprising. # Not considered a problem - just potentially surprising.
# To avoid it we would have to enumerate possible schemes. # To avoid it we would have to enumerate possible schemes.
# As it stands a unix system could define a 'scheme' that happens to match windows style driveletters. Consider a 'feature' ? review. # As it stands a unix system could define a 'scheme' that happens to match windows style driveletters. Consider a 'feature' ? review.
# won't fix? # won't fix?
#2) #2)
@ -164,16 +164,16 @@ namespace eval punk::path {
# normjoin ///server/share -> ///server/share # normjoin ///server/share -> ///server/share
#This is effectively an empty servername in the input with 'server' being pushed one level down - and the output is consistent #This is effectively an empty servername in the input with 'server' being pushed one level down - and the output is consistent
# possibly won't fix - review # possibly won't fix - review
#4) inconsistency #4) inconsistency
# we return normalized //server/share for //./UNC/server share # we return normalized //server/share for //./UNC/server share
# but other dos device paths are maintained # but other dos device paths are maintained
# e.g //./c:/etc # e.g //./c:/etc
# This is because such paths could contain alternate segment names (windows shortnames) which we aren't in a position to resolve. # This is because such paths could contain alternate segment names (windows shortnames) which we aren't in a position to resolve.
# caller should # caller should
# #as with 'case' below - caller will need to run a post 'file normalize' # #as with 'case' below - caller will need to run a post 'file normalize'
#5) we don't normalize case like file normalize does on windows platform. #5) we don't normalize case like file normalize does on windows platform.
# This is intentional. It could only be done with reference to underlying filesystem which we don't want here. # This is intentional. It could only be done with reference to underlying filesystem which we don't want here.
# #
# ================ # ================
# #
#relpaths all end up with leading . - while not always the simplest form, this is ok. (helps stop inadvertent conversions to absolutes) #relpaths all end up with leading . - while not always the simplest form, this is ok. (helps stop inadvertent conversions to absolutes)
@ -194,14 +194,14 @@ namespace eval punk::path {
/// { /// {
#if this is effectively //$emptyservername/ #if this is effectively //$emptyservername/
#then for consistency we should trail //<servername with a slash too? #then for consistency we should trail //<servername with a slash too?
#we can't transform to // or / #we can't transform to // or /
return /// return ///
#assert - code below should return /// (empty server prefix) for any number of leading slashes >=3 #assert - code below should return /// (empty server prefix) for any number of leading slashes >=3
#todo - shortcircuit that here? #todo - shortcircuit that here?
} }
} }
# /// # ///
set doubleslash1_posn [string first // $path] set doubleslash1_posn [string first // $path]
# -- --- --- temp warning on windows only - no x-platform difference in result # -- --- --- temp warning on windows only - no x-platform difference in result
#on windows //host is of type volumerelative #on windows //host is of type volumerelative
@ -221,7 +221,7 @@ namespace eval punk::path {
} }
# -- --- --- # -- --- ---
set is_relpath 0 set is_relpath 0
#set path [string map [list \\ /] $path] #set path [string map [list \\ /] $path]
set finalparts [list] set finalparts [list]
@ -264,11 +264,11 @@ namespace eval punk::path {
#normalize by dropping leading slash before split - and then treating first 2 segments as a root #normalize by dropping leading slash before split - and then treating first 2 segments as a root
#set parts [file split [string range $path 1 end]] #set parts [file split [string range $path 1 end]]
set parts [split $path /] set parts [split $path /]
#assert parts here has {} {} as first 2 entries #assert parts here has {} {} as first 2 entries
set rootindex 2 set rootindex 2
#currently prefer can backtrack to the //zipfs:/ scheme (below the mountpoint - to browse other mounts) #currently prefer can backtrack to the //zipfs:/ scheme (below the mountpoint - to browse other mounts)
#alternative handling for //zipfs:/path - don't go below mountpoint #alternative handling for //zipfs:/path - don't go below mountpoint
#but we can't determine just from string if mountpoint is direct subpath or a lower one e.g //zipfs:/arbitraryname/actualmountpoint #but we can't determine just from string if mountpoint is direct subpath or a lower one e.g //zipfs:/arbitraryname/actualmountpoint
#review - more generally //<mountmechanism>:/path ? #review - more generally //<mountmechanism>:/path ?
#todo - make an option for zipfs and others to determine the 'base' #todo - make an option for zipfs and others to determine the 'base'
#if {"zipfs:" eq [lindex $parts 2]} { #if {"zipfs:" eq [lindex $parts 2]} {
@ -281,7 +281,7 @@ namespace eval punk::path {
#set parts [file split $path] #set parts [file split $path]
set parts [::split $path /] set parts [::split $path /]
#e.g /a/b/c -> {} a b c #e.g /a/b/c -> {} a b c
#or relative path a/b/c -> a b c #or relative path a/b/c -> a b c
#or c:/a/b/c -> c: a b c #or c:/a/b/c -> c: a b c
if {[string match *: [lindex $parts 0]]} { if {[string match *: [lindex $parts 0]]} {
if {[lindex $parts 1] eq ""} { if {[lindex $parts 1] eq ""} {
@ -295,9 +295,9 @@ namespace eval punk::path {
} elseif {[lindex $parts 0] ne ""} { } elseif {[lindex $parts 0] ne ""} {
#relpath a/b/c #relpath a/b/c
set parts [linsert $parts 0 .] set parts [linsert $parts 0 .]
set rootindex 0 set rootindex 0
#allow backtracking arbitrarily for leading .. entries - simplify where possible #allow backtracking arbitrarily for leading .. entries - simplify where possible
#also need to stop possible conversion to absolute path #also need to stop possible conversion to absolute path
set is_relpath 1 set is_relpath 1
} }
} }
@ -306,7 +306,7 @@ namespace eval punk::path {
#puts stderr "-->baseparts:$baseparts" #puts stderr "-->baseparts:$baseparts"
#ensure that if our rootindex already spans a dotted segment (after the first one) we remove it #ensure that if our rootindex already spans a dotted segment (after the first one) we remove it
#must maintain initial . for relpaths to stop them converting to absolute via backtrack #must maintain initial . for relpaths to stop them converting to absolute via backtrack
# #
set finalparts [list [lindex $baseparts 0]] set finalparts [list [lindex $baseparts 0]]
foreach b [lrange $baseparts 1 end] { foreach b [lrange $baseparts 1 end] {
if {$b ni {. ..}} { if {$b ni {. ..}} {
@ -333,7 +333,7 @@ namespace eval punk::path {
lappend finalparts $p lappend finalparts $p
} }
} }
incr i incr i
} }
} else { } else {
foreach p [lrange $parts $rootindex+1 end] { foreach p [lrange $parts $rootindex+1 end] {
@ -345,7 +345,7 @@ namespace eval punk::path {
switch -exact -- $p { switch -exact -- $p {
. - "" {} . - "" {}
.. { .. {
lpop finalparts ;#uses punk::lib::compat::lpop if on < 8.7 lpop finalparts ;#uses punk::lib::compat::lpop if on < 8.7
} }
default { default {
lappend finalparts $p lappend finalparts $p
@ -403,16 +403,16 @@ namespace eval punk::path {
} }
#x-platform - punk::path::pathtype - can be used in safe interps - different concept of pathtypes to 'file pathtype' #x-platform - punk::path::pathtype - can be used in safe interps - different concept of pathtypes to 'file pathtype'
# - no volumerelative # - no volumerelative
# - no lookup of file volumes (volume is a windows concept - but with //zipfs:/ somewhat applicable to other platforms) # - no lookup of file volumes (volume is a windows concept - but with //zipfs:/ somewhat applicable to other platforms)
# - /* as absolute (covers also //zipfs:/ (volume), //server , //./etc , //./UNC) # - /* as absolute (covers also //zipfs:/ (volume), //server , //./etc , //./UNC)
# - xxx:// as absolute (scheme) # - xxx:// as absolute (scheme)
# - xxx:/ or x:/ as absolute # - xxx:/ or x:/ as absolute
# - x: xxx: -> as absolute (volume-basic or volume-extended) # - x: xxx: -> as absolute (volume-basic or volume-extended)
#note also on windows - legacy name for COM devices #note also on windows - legacy name for COM devices
# COM1 = COM1: # COM1 = COM1:
# //./COM1 ?? review # //./COM1 ?? review
proc pathtype {str} { proc pathtype {str} {
@ -425,7 +425,7 @@ namespace eval punk::path {
return absolute return absolute
} }
#only firstsegment with single colon at last position (after some non empty string) counts as volume or scheme - review #only firstsegment with single colon at last position (after some non empty string) counts as volume or scheme - review
#e.g a:b:/.. or a::/.. or :/.. is not treated as volume/scheme whereas ab:/ is. #e.g a:b:/.. or a::/.. or :/.. is not treated as volume/scheme whereas ab:/ is.
set firstslash [string first / $str] set firstslash [string first / $str]
if {$firstslash == -1} { if {$firstslash == -1} {
@ -434,9 +434,9 @@ namespace eval punk::path {
set firstsegment [string range $str 0 $firstslash-1] set firstsegment [string range $str 0 $firstslash-1]
} }
if {[set firstc [string first : $firstsegment]] > 0} { if {[set firstc [string first : $firstsegment]] > 0} {
set lhs_firstsegment [string range $firstsegment 0 $firstc-1] set lhs_firstsegment [string range $firstsegment 0 $firstc-1]
set rhs_firstsegment [string range $firstsegment $firstc+1 end] ;#exclude a:b/ etc set rhs_firstsegment [string range $firstsegment $firstc+1 end] ;#exclude a:b/ etc
if {$rhs_firstsegment eq ""} { if {$rhs_firstsegment eq ""} {
set rhs_entire_path [string range $str $firstc+1 end] set rhs_entire_path [string range $str $firstc+1 end]
#assert lhs_firstsegment not empty since firstc > 0 #assert lhs_firstsegment not empty since firstc > 0
#count following / sequence #count following / sequence
@ -466,7 +466,7 @@ namespace eval punk::path {
} }
} }
} }
#assert first element of any return has been absolute or relative #assert first element of any return has been absolute or relative
return relative return relative
} }
@ -489,7 +489,7 @@ namespace eval punk::path {
} }
return $str return $str
} }
#purely string based - no reference to filesystem knowledge #purely string based - no reference to filesystem knowledge
#unix-style forward slash only #unix-style forward slash only
proc plainjoin {args} { proc plainjoin {args} {
set args [lmap a $args {string map "\\\\ /" $a}] set args [lmap a $args {string map "\\\\ /" $a}]
@ -499,12 +499,12 @@ namespace eval punk::path {
set out "" set out ""
foreach a $args { foreach a $args {
if {![string length $out]} { if {![string length $out]} {
append out [plain $a] append out [plain $a]
} else { } else {
set a [plain $a] set a [plain $a]
if {[string map {/ ""} $out] eq ""} { if {[string map {/ ""} $out] eq ""} {
set out [string range $out 0 end-1] set out [string range $out 0 end-1]
} }
if {[string map {/ ""} $a] eq ""} { if {[string map {/ ""} $a] eq ""} {
#all / segment #all / segment
@ -512,16 +512,16 @@ namespace eval punk::path {
} else { } else {
if {[string length $a] > 2 && [string match "./*" $a]} { if {[string length $a] > 2 && [string match "./*" $a]} {
set a [string range $a 2 end] set a [string range $a 2 end]
} }
if {[string index $out end] eq "/"} { if {[string index $out end] eq "/"} {
append out $a append out $a
} else { } else {
append out / $a append out / $a
} }
} }
} }
} }
return $out return $out
} }
proc plainjoin1 {args} { proc plainjoin1 {args} {
if {[llength $args] == 1} { if {[llength $args] == 1} {
@ -530,9 +530,9 @@ namespace eval punk::path {
set out [trim_final_slash [lindex $args 0]] set out [trim_final_slash [lindex $args 0]]
foreach a [lrange $args 1 end] { foreach a [lrange $args 1 end] {
set a [trim_final_slash $a] set a [trim_final_slash $a]
append out / $a append out / $a
} }
return $out return $out
} }
#intention? #intention?
@ -554,13 +554,13 @@ namespace eval punk::path {
#*** !doctools #*** !doctools
#[call [fun pathglob_as_re] [arg pathglob]] #[call [fun pathglob_as_re] [arg pathglob]]
#[para] Returns a regular expression for matching a path to a glob pattern which can contain glob chars *|? in any segment of the path structure #[para] Returns a regular expression for matching a path to a glob pattern which can contain glob chars *|? in any segment of the path structure
#[para] ** matches any number of subdirectories. #[para] ** matches any number of subdirectories.
#[para] e.g /etc/**/*.txt will match any .txt files at any depth below /etc (except directly within /etc itself) #[para] e.g /etc/**/*.txt will match any .txt files at any depth below /etc (except directly within /etc itself)
#[para] e.g /etc/**.txt will match any .txt files at any depth below /etc #[para] e.g /etc/**.txt will match any .txt files at any depth below /etc
#[para] any segment that does not contain ** must match exactly one segment in the path #[para] any segment that does not contain ** must match exactly one segment in the path
#[para] e.g the glob /etc/*/*.doc - will match any .doc files that are exactly one tree level below /etc #[para] e.g the glob /etc/*/*.doc - will match any .doc files that are exactly one tree level below /etc
#[para] The pathglob doesn't have to contain glob characters, in which case the returned regex will match the pathglob exactly as specified. #[para] The pathglob doesn't have to contain glob characters, in which case the returned regex will match the pathglob exactly as specified.
#[para] Regular expression syntax is deliberateley not supported within the pathglob string so that supplied regex characters will be treated as literals #[para] Regular expression syntax is deliberateley not supported within the pathglob string so that supplied regex characters will be treated as literals
#todo - consider whether a way to escape the glob chars ? * is practical - to allow literals ? * #todo - consider whether a way to escape the glob chars ? * is practical - to allow literals ? *
@ -572,9 +572,9 @@ namespace eval punk::path {
} }
switch -- $seg { switch -- $seg {
* {lappend pats {[^/]*}} * {lappend pats {[^/]*}}
** {lappend pats {.*}} ** {lappend pats {.*}}
default { default {
set seg [string map [list {^ {\^} $ {\$} [} {\[} ( {\(} \{ \\\{ \\ {\\}] $seg] ;#treat regex characters in the input as literals set seg [string map [list {^ {\^} $ {\$} [} {\[} ( {\(} \{ \\\{ \\ {\\}] $seg] ;#treat regex characters in the input as literals
#set seg [string map [list . {[.]}] $seg] #set seg [string map [list . {[.]}] $seg]
set seg [string map {. [.]} $seg] set seg [string map {. [.]} $seg]
if {[regexp {[*?]} $seg]} { if {[regexp {[*?]} $seg]} {
@ -614,14 +614,14 @@ namespace eval punk::path {
} }
} }
} }
# -- --- --- --- --- --- # -- --- --- --- --- ---
set opt_nocase [dict get $opts -nocase] set opt_nocase [dict get $opts -nocase]
set explicit_nocase 1 ;#default to disprove set explicit_nocase 1 ;#default to disprove
if {$opt_nocase eq "\uFFFF"} { if {$opt_nocase eq "\uFFFF"} {
set opt_nocase 0 set opt_nocase 0
set explicit_nocase 0 set explicit_nocase 0
} }
# -- --- --- --- --- --- # -- --- --- --- --- ---
if {$opt_nocase} { if {$opt_nocase} {
return [regexp -nocase [pathglob_as_re $pathglob] $path] return [regexp -nocase [pathglob_as_re $pathglob] $path]
} else { } else {
@ -651,33 +651,33 @@ namespace eval punk::path {
-call-depth-internal -default 0 -type integer -call-depth-internal -default 0 -type integer
-antiglob_paths -default {} -help\ -antiglob_paths -default {} -help\
"list of path patterns to exclude "list of path patterns to exclude
may include * and ** path segments e.g may include * and ** path segments e.g
/usr/** (exlude subfolders based at /usr but not /usr/** (exlude subfolders based at /usr but not
files within /usr itself) files within /usr itself)
**/_aside (exlude files where _aside is last segment) **/_aside (exlude files where _aside is last segment)
**/_aside/* (exclude folders one below an _aside folder) **/_aside/* (exclude folders one below an _aside folder)
**/_aside/** (exclude all folders with _aside as a segment)" **/_aside/** (exclude all folders with _aside as a segment)"
@values -min 0 -max -1 -optional 1 -type string @values -min 0 -max -1 -optional 1 -type string
tailglobs -default * -multiple 1 -help\ tailglobs -default * -multiple 1 -help\
"Patterns to match against filename portion (last segment) of each file path "Patterns to match against filename portion (last segment) of each file path
within the directory tree being searched." within the directory tree being searched."
} }
#todo - implement treefiles which acts like dirfiles but allows path globbing in the same way as punk::ns::ns/ #todo - implement treefiles which acts like dirfiles but allows path globbing in the same way as punk::ns::ns/
#then review if treefiles can replace dirfiles or if both should exist (dirfiles can have literal glob chars in path segments - but that is a rare usecase) #then review if treefiles can replace dirfiles or if both should exist (dirfiles can have literal glob chars in path segments - but that is a rare usecase)
proc treefilenames {args} { proc treefilenames {args} {
#*** !doctools #*** !doctools
#[call [fun treefilenames] [opt {option value...}] [opt {globpattern...}]] #[call [fun treefilenames] [opt {option value...}] [opt {globpattern...}]]
#[para]basic (glob based) list of filenames matching each pattern in tailglobs - recursive #[para]basic (glob based) list of filenames matching each pattern in tailglobs - recursive
#[para] options: #[para] options:
#[para] [opt -dir] <path> #[para] [opt -dir] <path>
#[para] defaults to [lb]pwd[rb] - base path for tree to search #[para] defaults to [lb]pwd[rb] - base path for tree to search
#[para] [opt -antiglob_paths] <list> #[para] [opt -antiglob_paths] <list>
#[para] list of path patterns to exclude - may include * and ** path segments e.g /usr/** #[para] list of path patterns to exclude - may include * and ** path segments e.g /usr/**
#[para]no natsorting - so order is dependent on filesystem #[para]no natsorting - so order is dependent on filesystem
set argd [punk::args::parse $args withid ::punk::path::treefilenames] set argd [punk::args::parse $args withid ::punk::path::treefilenames]
lassign [dict values $argd] leaders opts values received lassign [dict values $argd] leaders opts values received
set tailglobs [dict get $values tailglobs] set tailglobs [dict get $values tailglobs]
# -- --- --- --- --- --- --- # -- --- --- --- --- --- ---
set opt_antiglob_paths [dict get $opts -antiglob_paths] set opt_antiglob_paths [dict get $opts -antiglob_paths]
@ -694,7 +694,7 @@ namespace eval punk::path {
set opt_dir [dict get $opts -directory] set opt_dir [dict get $opts -directory]
} }
if {![file isdirectory $opt_dir]} { if {![file isdirectory $opt_dir]} {
return [list] return [list]
} }
} else { } else {
#assume/require to exist in any recursive call #assume/require to exist in any recursive call
@ -713,15 +713,26 @@ namespace eval punk::path {
} }
#todo - account for vfs where matched path could appear to be a directory but is mounted so could be a desired match? #todo - account for vfs where matched path could appear to be a directory but is mounted so could be a desired match?
set dirfiles [lsort [glob -nocomplain -dir $opt_dir -type f {*}$tailglobs]] if {[catch {glob -nocomplain -dir $opt_dir -type f {*}$tailglobs} matches]} {
#we can get for example a permissions error
puts stderr "treefilenames error while listing files in dir $opt_dir\n $matches"
set dirfiles [list]
} else {
set dirfiles [lsort $matches]
}
lappend files {*}$dirfiles lappend files {*}$dirfiles
set dirdirs [glob -nocomplain -dir $opt_dir -type d *] if {[catch {glob -nocomplain -dir $opt_dir -type d *} dirdirs]} {
puts stderr "treefilenames error while listing subdirs in dir $opt_dir\n $dirdirs"
set dirdirs [list]
}
foreach dir $dirdirs { foreach dir $dirdirs {
set skip 0 set skip 0
foreach anti $opt_antiglob_paths { foreach anti $opt_antiglob_paths {
if {[globmatchpath $anti $dir]} { if {[globmatchpath $anti $dir]} {
set skip 1 set skip 1
break break
} }
} }
if {$skip} { if {$skip} {
@ -743,8 +754,8 @@ namespace eval punk::path {
#[item] #[item]
#[para] Arguments: #[para] Arguments:
# [list_begin arguments] # [list_begin arguments]
# [arg_def string reference] The path from which the relative path to location is determined. # [arg_def string reference] The path from which the relative path to location is determined.
# [arg_def string location] The location path which may be above or below the reference path # [arg_def string location] The location path which may be above or below the reference path
# [list_end] # [list_end]
#[item] #[item]
#[para] Results: #[para] Results:
@ -753,7 +764,7 @@ namespace eval punk::path {
#[item] #[item]
#[para] Notes: #[para] Notes:
#[para] Both paths must be the same type - ie both absolute or both relative #[para] Both paths must be the same type - ie both absolute or both relative
#[para] Case sensitive. ie punk::path::relative /etc /etC #[para] Case sensitive. ie punk::path::relative /etc /etC
# will return ../etC # will return ../etC
#[para] On windows, the drive-letter component (only) is not case sensitive #[para] On windows, the drive-letter component (only) is not case sensitive
#[example_begin] #[example_begin]
@ -774,7 +785,7 @@ namespace eval punk::path {
#[example_begin] #[example_begin]
# P% punk::path::relative /usr/local/etc/ /usr/local/etc/somewhere/below # P% punk::path::relative /usr/local/etc/ /usr/local/etc/somewhere/below
# - somewhere/below # - somewhere/below
# P% punk::path::relative /usr/local/etc/somewhere /usr/local/lib/here # P% punk::path::relative /usr/local/etc/somewhere /usr/local/lib/here
# - ../../lib/here # - ../../lib/here
#[example_end] #[example_end]
#[list_end] #[list_end]
@ -791,7 +802,7 @@ namespace eval punk::path {
#avoid normalizing if possible (file normalize *very* expensive on windows) #avoid normalizing if possible (file normalize *very* expensive on windows)
set do_normalize 0 set do_normalize 0
if {[file pathtype $reference] eq "relative"} { if {[file pathtype $reference] eq "relative"} {
#if reference is relative so is location #if reference is relative so is location
if {[regexp {[.]{2}} [list $reference $location]]} { if {[regexp {[.]{2}} [list $reference $location]]} {
set do_normalize 1 set do_normalize 1
} }
@ -857,7 +868,7 @@ namespace eval punk::path::lib {
namespace path [namespace parent] namespace path [namespace parent]
#*** !doctools #*** !doctools
#[subsection {Namespace punk::path::lib}] #[subsection {Namespace punk::path::lib}]
#[para] Secondary functions that are part of the API #[para] Secondary functions that are part of the API
#[list_begin definitions] #[list_begin definitions]
@ -877,17 +888,17 @@ namespace eval punk::path::lib {
namespace eval punk::path::system { namespace eval punk::path::system {
#*** !doctools #*** !doctools
#[subsection {Namespace punk::path::system}] #[subsection {Namespace punk::path::system}]
#[para] Internal functions that are not part of the API #[para] Internal functions that are not part of the API
} }
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready ## Ready
package provide punk::path [namespace eval punk::path { package provide punk::path [namespace eval punk::path {
variable pkg punk::path variable pkg punk::path
variable version variable version
set version 999999.0a1.0 set version 999999.0a1.0
}] }]
return return

31
src/modules/textblock-999999.0a1.0.tm
Unescape View File

@ -5974,13 +5974,40 @@ tcl::namespace::eval textblock {
[>punk . rhs]\ [>punk . rhs]\
[punk::lib::list_as_lines -- [lrepeat 8 " | "]] [punk::lib::list_as_lines -- [lrepeat 8 " | "]]
} }
punk::args::define [punk::lib::tstr -return string {
@id -id ::textblock::table
@cmd -name "textblock::table" -help\
"A wrapper for creating a textblock::class::table
NOTE: more options available - argument definition
is incomplete"
@opts
-return -choices {table tableobject}
-rows -type list -default "" -help\
"A list of lists.
Each toplevel element represents a row.
The number of elements in each row must
be the same.
e.g for 2 rows and 3 columns:
table -rows {{r0c0 r0c1 r0c2} {r1c0 r1c1 r1c2}}
"
-headers -type list -default "" -help\
"This is a simplified form where each column
has a single header row.
Each element in this list goes into the top
header row for a column.
More complex header arrangements where each
column has multiple headers can be made
by using -return tableobject and calling
$tableobj configure_column <idx> -headers"
}]
proc table {args} { proc table {args} {
#todo - use punk::args #todo - use punk::args
upvar ::textblock::class::opts_table_defaults toptdefaults upvar ::textblock::class::opts_table_defaults toptdefaults
set defaults [tcl::dict::create\ set defaults [tcl::dict::create\
-rows [list]\ -rows [list]\
-headers [list]\ -headers [list]\
-return string\ -return table\
] ]
@ -6017,7 +6044,7 @@ tcl::namespace::eval textblock {
if {$opt_return eq "string"} { if {$opt_return eq "table"} {
set result [$t print] set result [$t print]
$t destroy $t destroy
return $result return $result

326
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm
Unescape View File

@ -331,26 +331,26 @@ tcl::namespace::eval punk::args {
parsing and help display. parsing and help display.
directives include: directives include:
%B%@id%N% ?opt val...? %B%@id%N% ?opt val...?
options: -id <str> spec-options: -id <str>
%B%@cmd%N% ?opt val...? %B%@cmd%N% ?opt val...?
options: -name <str> -help <str> spec-options: -name <str> -help <str>
%B%@leaders%N% ?opt val...? %B%@leaders%N% ?opt val...?
options: -min <int> -max <int> spec-options: -min <int> -max <int>
(used for leading args that come before switches/opts) (used for leading args that come before switches/opts)
%B%@opts%N% ?opt val...? %B%@opts%N% ?opt val...?
options: -any <bool> spec-options: -any <bool>
%B%@values%N% ?opt val...? %B%@values%N% ?opt val...?
options: -min <int> -max <int> spec-options: -min <int> -max <int>
(used for trailing args that come after switches/opts) (used for trailing args that come after switches/opts)
%B%@argdisplay%N% ?opt val...? %B%@argdisplay%N% ?opt val...?
options: -header <str> (text for header row of table) spec-options: -header <str> (text for header row of table)
-body <str> (text to replace autogenerated arg info) -body <str> (text to replace autogenerated arg info)
%B%@doc%N% ?opt val...? %B%@doc%N% ?opt val...?
options: -name <str> -url <str> spec-options: -name <str> -url <str>
%B%@seealso%N% ?opt val...? %B%@seealso%N% ?opt val...?
options: -name <str> -url <str> (for footer - unimplemented) spec-options: -name <str> -url <str> (for footer - unimplemented)
Some other options normally present on custom arguments are available Some other spec-options normally present on custom arguments are available
to use with the @leaders @opts @values directives to set defaults to use with the @leaders @opts @values directives to set defaults
for subsequent lines that represent your custom arguments. for subsequent lines that represent your custom arguments.
These directives should occur in exactly this order - but can be These directives should occur in exactly this order - but can be
@ -361,7 +361,12 @@ tcl::namespace::eval punk::args {
or using the i <cmd>.. function - an @id with -id <value> is needed. or using the i <cmd>.. function - an @id with -id <value> is needed.
All directives can be omitted, in which case every line represents All directives can be omitted, in which case every line represents
a custom value or option. a custom leader, value or option.
All will be leaders by default if no options defined.
If options are defined (by naming with leading dash, or explicitly
specifying @opts) then the definitions prior to the options will be
categorised as leaders, and those following the options will be
categorised as values.
Custom arguments are defined by using any word at the start of a Custom arguments are defined by using any word at the start of a
line that doesn't begin with @ or - line that doesn't begin with @ or -
@ -369,7 +374,7 @@ tcl::namespace::eval punk::args {
that @@somearg becomes an argument named @somearg) that @@somearg becomes an argument named @somearg)
custom leading args, switches/options (names starting with -) custom leading args, switches/options (names starting with -)
and trailing values also take options: and trailing values also take spec-options:
-type <typename> -type <typename>
defaults to string. If no other restrictions defaults to string. If no other restrictions
@ -397,12 +402,22 @@ tcl::namespace::eval punk::args {
-optional <boolean> -optional <boolean>
(defaults to true for flags/switches false otherwise) (defaults to true for flags/switches false otherwise)
For non flag/switch arguments - all arguments with
-optional true must sit consecutively within their group.
ie all optional leader arguments must be together, and all
optional value arguments must be together. Furthermore,
specifying both optional leaders and optional values will
often lead to ambiguous parsing results. Currently, all
optional non-flg/switch arguments should be either at the
trailing end of leaders or the trailing end of values.
Further unambiguous arrangements of optional args may be
made in future - but are currently considered 'unsupported'
-default <value> -default <value>
-multiple <bool> (for leaders & values defines whether -multiple <bool> (for leaders & values defines whether
subsequent received values are stored agains the same subsequent received values are stored against the same
argument name - only applies to final leader or value) argument name - only applies to final leader OR final value)
(for options/flags this allows the opt-val pair or solo (for options/flags this allows the opt-val pair or solo
flag to appear multiple times - no necessarily contiguously) flag to appear multiple times - not necessarily contiguously)
-choices {<choicelist>} -choices {<choicelist>}
A list of allowable values for an argument. A list of allowable values for an argument.
The -default value doesn't have to be in the list. The -default value doesn't have to be in the list.
@ -438,7 +453,7 @@ tcl::namespace::eval punk::args {
Max of -1 represents no upper limit. Max of -1 represents no upper limit.
If <range> allows more than one choice the value is a list If <range> allows more than one choice the value is a list
consisting of items in the choices made available through consisting of items in the choices made available through
entries in -choices/-choicegrups. entries in -choices/-choicegroups.
-minsize (type dependant) -minsize (type dependant)
-maxsize (type dependant) -maxsize (type dependant)
-range (type dependant) -range (type dependant)
@ -1667,6 +1682,7 @@ tcl::namespace::eval punk::args {
" "
@leaders -min 0 -max 0 @leaders -min 0 -max 0
@opts @opts
-return -default text -choices {text dict}
-form -default 0 -help\ -form -default 0 -help\
"Ordinal index or name of command form" "Ordinal index or name of command form"
@ -1694,7 +1710,7 @@ tcl::namespace::eval punk::args {
(directives are lines beginning with (directives are lines beginning with
@ e.g @id, @cmd etc) @ e.g @id, @cmd etc)
if -type is @leaders,@opts or @values matches from that type if -type is leaders,opts or values matches from that type
will be returned. will be returned.
if -type is another directive such as @id, @doc etc the if -type is another directive such as @id, @doc etc the
@ -1706,8 +1722,10 @@ tcl::namespace::eval punk::args {
proc resolved_def {args} { proc resolved_def {args} {
#not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only.
set opts [dict create\ set opts [dict create\
-types {}\ -return text\
-types {}\
-form 0\ -form 0\
-antiglobs {}\ -antiglobs {}\
-override {}\ -override {}\
@ -1743,7 +1761,7 @@ tcl::namespace::eval punk::args {
} }
dict for {k v} $opts { dict for {k v} $opts {
switch -- $k { switch -- $k {
-form - -types - -antiglobs - -override {} -return - -form - -types - -antiglobs - -override {}
default { default {
punk::args::parse $args withid ::punk::args::resolved_def punk::args::parse $args withid ::punk::args::resolved_def
return return
@ -1764,163 +1782,185 @@ tcl::namespace::eval punk::args {
variable id_cache_rawdef variable id_cache_rawdef
set realid [real_id $id] set realid [real_id $id]
if {$realid eq ""} {
return
}
if {$realid ne ""} { set deflist [tcl::dict::get $id_cache_rawdef $realid]
set deflist [tcl::dict::get $id_cache_rawdef $realid] set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]]
set result ""
set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]]
set opt_form [dict get $opts -form] set opt_form [dict get $opts -form]
if {[string is integer -strict $opt_form]} { if {[string is integer -strict $opt_form]} {
set formname [lindex [dict get $specdict form_names] $opt_form] set formname [lindex [dict get $specdict form_names] $opt_form]
} else { } else {
set formname $opt_form set formname $opt_form
} }
set opt_override [dict get $opts -override] set opt_override [dict get $opts -override]
set opt_return [dict get $opts -return]
#set arg_info [dict get $specdict ARG_INFO]
set arg_info [dict get $specdict FORMS $formname ARG_INFO] #set arg_info [dict get $specdict ARG_INFO]
set argtypes [dict create leaders leader opts option values value] set arg_info [dict get $specdict FORMS $formname ARG_INFO]
set argtypes [dict create leaders leader opts option values value]
set opt_antiglobs [dict get $opts -antiglobs]
set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] set opt_antiglobs [dict get $opts -antiglobs]
set suppressed_directives [list] set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *]
set suppressed_args [list] set suppressed_directives [list]
foreach ag $opt_antiglobs { set suppressed_args [list]
foreach d $directives { foreach ag $opt_antiglobs {
if {[string match $ag $d]} { foreach d $directives {
lappend suppressed_directives $d if {[string match $ag $d]} {
} lappend suppressed_directives $d
} }
foreach argname [dict keys $arg_info] { }
if {[string match $ag $argname]} { foreach argname [dict keys $arg_info] {
lappend suppressed_args $argname if {[string match $ag $argname]} {
} lappend suppressed_args $argname
} }
} }
set suppressed_directives [lsort -unique $suppressed_directives] }
set suppressed_args [lsort -unique $suppressed_args] set suppressed_directives [lsort -unique $suppressed_directives]
set suppressed_args [lsort -unique $suppressed_args]
set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives]
set globbed [list] set globbed [list]
foreach pat $patterns { foreach pat $patterns {
set matches [dict keys $arg_info $pat] set matches [dict keys $arg_info $pat]
lappend globbed {*}$matches lappend globbed {*}$matches
} }
set globbed [lsort -unique $globbed] set globbed [lsort -unique $globbed]
set included_args [punk::args::system::punklib_ldiff $globbed $suppressed_args] set included_args [punk::args::system::punklib_ldiff $globbed $suppressed_args]
foreach type $typelist {
switch -exact -- $type {
* {
if {"@id" in $included_directives} {
if {[dict exists $opt_override @id]} {
append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]"
} else {
append result \n "@id -id [dict get $specdict id]"
}
}
foreach directive {@package @cmd @doc @seealso @argdisplay} {
set dshort [string range $directive 1 end]
if {"$directive" in $included_directives} {
if {[dict exists $opt_override $directive]} {
append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]"
} else {
append result \n "$directive [dict get $specdict ${dshort}_info]"
}
}
}
#output ordered by leader, option, value
foreach pseudodirective {leaders opts values} tp {leader option value} {
set directive "@$pseudodirective"
switch -- $directive {
@leaders {set defaults_key leaderspec_defaults}
@opts {set defaults_key optspec_defaults}
@values {set defaults_key valspec_defaults}
}
if {"$directive" in $included_directives} {
if {[dict exists $opt_override "$directive"]} {
append result \n "$directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]"
} else {
append result \n "$directive [dict get $specdict $defaults_key]"
}
}
if {$pseudodirective in $included_directives} { set result ""
foreach m $included_args { set resultdict [dict create]
set argspec [dict get $arg_info $m] foreach type $typelist {
if {[dict get $argspec -ARGTYPE] eq $tp} { switch -exact -- $type {
set argspec [dict remove $argspec -ARGTYPE] * {
if {[dict exists $opt_override $m]} { if {"@id" in $included_directives} {
append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" if {[dict exists $opt_override @id]} {
} else { append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]"
append result \n "$m $argspec" dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]
} } else {
} append result \n "@id -id [dict get $specdict id]"
} dict set resultdict @id [list -id [dict get $specdict id]]
}
} }
} }
@id { foreach directive {@package @cmd @doc @seealso @argdisplay} {
if {"@id" in $included_directives} { set dshort [string range $directive 1 end]
#only a single id record can exist if {"$directive" in $included_directives} {
if {[dict exists $opt_override @id]} { if {[dict exists $opt_override $directive]} {
append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]"
dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]
} else { } else {
append result \n "@id -id [dict get $specdict id]" append result \n "$directive [dict get $specdict ${dshort}_info]"
dict set resultdict $directive [dict get $specdict ${dshort}_info]
} }
} }
} }
@package - @cmd - @doc - @seealso - @argdisplay { #output ordered by leader, option, value
if {"$type" in $included_directives} { foreach pseudodirective {leaders opts values} tp {leader option value} {
set tp [string range $type 1 end] ;# @package -> package set directive "@$pseudodirective"
if {[dict exists $opt_override $type]} { switch -- $directive {
append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" @leaders {set defaults_key leaderspec_defaults}
} else { @opts {set defaults_key optspec_defaults}
append result \n "$type [dict get $specdict ${tp}_info]" @values {set defaults_key valspec_defaults}
}
} }
}
@leaders - @opts - @values { if {"$directive" in $included_directives} {
#these are the active defaults for further arguments if {[dict exists $opt_override "$directive"]} {
if {"$type" in $included_directives} { append result \n "$directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]"
switch -- $type { dict set resultdict $directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]
@leaders {set defaults_key leaderspec_defaults}
@opts {set defaults_key optspec_defaults}
@values {set defaults_key valspec_defaults}
}
if {[dict exists $opt_override $type]} {
append result \n "$type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]]"
} else { } else {
append result \n "$type [dict get $specdict leaderspec_defaults]" append result \n "$directive [dict get $specdict $defaults_key]"
dict set resultdict $directive [dict get $specdict $defaults_key]
} }
} }
}
leaders - opts - values { if {$pseudodirective in $included_directives} {
#pseudo-directives
if {$type in $included_directives} {
foreach m $included_args { foreach m $included_args {
set argspec [dict get $arg_info $m] set argspec [dict get $arg_info $m]
if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { if {[dict get $argspec -ARGTYPE] eq $tp} {
set argspec [dict remove $argspec -ARGTYPE] set argspec [dict remove $argspec -ARGTYPE]
if {[dict exists $opt_override $m]} { if {[dict exists $opt_override $m]} {
append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" append result \n "$m [dict merge $argspec [dict get $opt_override $m]]"
dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]]
} else { } else {
append result \n "$m $argspec" append result \n "$m $argspec"
dict set resultdict $m $argspec
} }
} }
} }
} }
} }
default {
}
@id {
if {"@id" in $included_directives} {
#only a single id record can exist
if {[dict exists $opt_override @id]} {
append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]"
dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]
} else {
append result \n "@id -id [dict get $specdict id]"
dict set resultdict @id [list -id [dict get $specdict id]]
}
} }
} }
@package - @cmd - @doc - @seealso - @argdisplay {
if {"$type" in $included_directives} {
set tp [string range $type 1 end] ;# @package -> package
if {[dict exists $opt_override $type]} {
append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]"
dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]
} else {
append result \n "$type [dict get $specdict ${tp}_info]"
dict set resultdict $type [dict get $specdict ${tp}_info]
}
}
}
@leaders - @opts - @values {
#these are the active defaults for further arguments
if {"$type" in $included_directives} {
switch -- $type {
@leaders {set defaults_key leaderspec_defaults}
@opts {set defaults_key optspec_defaults}
@values {set defaults_key valspec_defaults}
}
if {[dict exists $opt_override $type]} {
append result \n "$type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]]"
dict set resultdict $type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]]
} else {
append result \n "$type [dict get $specdict leaderspec_defaults]"
dict set resultdict $type [dict get $specdict leaderspec_defaults]
}
}
}
leaders - opts - values {
#pseudo-directives
if {$type in $included_directives} {
foreach m $included_args {
set argspec [dict get $arg_info $m]
if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} {
set argspec [dict remove $argspec -ARGTYPE]
if {[dict exists $opt_override $m]} {
append result \n "$m [dict merge $argspec [dict get $opt_override $m]]"
dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]]
} else {
append result \n "$m $argspec"
dict set resultdict $m $argspec
}
}
}
}
}
default {
}
}
if {$opt_return eq "text"} {
return $result
} else {
return $resultdict
} }
return $result
} }
} }

153
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm
Unescape View File

@ -20,7 +20,7 @@
#[manpage_begin punkshell_module_punk::path 0 0.1.0] #[manpage_begin punkshell_module_punk::path 0 0.1.0]
#[copyright "2023"] #[copyright "2023"]
#[titledesc {Filesystem path utilities}] [comment {-- Name section and table of contents description --}] #[titledesc {Filesystem path utilities}] [comment {-- Name section and table of contents description --}]
#[moddesc {punk path filesystem utils}] [comment {-- Description at end of page heading --}] #[moddesc {punk path filesystem utils}] [comment {-- Description at end of page heading --}]
#[require punk::path] #[require punk::path]
#[description] #[description]
#[keywords module path filesystem] #[keywords module path filesystem]
@ -104,21 +104,21 @@ namespace eval punk::path {
#*** !doctools #*** !doctools
#[subsection {Namespace punk::path}] #[subsection {Namespace punk::path}]
#[para] Core API functions for punk::path #[para] Core API functions for punk::path
#[list_begin definitions] #[list_begin definitions]
# -- --- # -- ---
#punk::path::normjoin #punk::path::normjoin
# - simplify . and .. segments as far as possible whilst respecting specific types of root. # - simplify . and .. segments as far as possible whilst respecting specific types of root.
# -- --- # -- ---
#a form of file normalize that supports //xxx to be treated as server path names #a form of file normalize that supports //xxx to be treated as server path names
#(ie regardless of unices ignoring (generally) leading double slashes, and regardless of windows volumerelative path syntax) #(ie regardless of unices ignoring (generally) leading double slashes, and regardless of windows volumerelative path syntax)
#(sometimes //server.com used as a short form for urls - which doesn't seem too incompatible with this anyway) #(sometimes //server.com used as a short form for urls - which doesn't seem too incompatible with this anyway)
# -- --- # -- ---
#This is intended to be purely a string analysis - without reference to filesystem volumes or vfs or zipfs mountpoints etc #This is intended to be purely a string analysis - without reference to filesystem volumes or vfs or zipfs mountpoints etc
# #
#TODO - option for caller to provide a -base below which we can't backtrack. #TODO - option for caller to provide a -base below which we can't backtrack.
#This is preferable to setting policy here for example regarding forcing no trackback below //servername/share #This is preferable to setting policy here for example regarding forcing no trackback below //servername/share
#Our default is to allow trackback to: #Our default is to allow trackback to:
# <scheme>://<something> # <scheme>://<something>
# <driveletter>:/ # <driveletter>:/
@ -128,7 +128,7 @@ namespace eval punk::path {
# ./../<repeated> - (track back indefinitely on relpath as we are not resolving to anything physical and can't fully simplify the leading backtracks) # ./../<repeated> - (track back indefinitely on relpath as we are not resolving to anything physical and can't fully simplify the leading backtracks)
# #
#The caller should do the file/vfs operations to determine this - not us. #The caller should do the file/vfs operations to determine this - not us.
# -- --- # -- ---
#simplify path with respect to /./ & /../ elements - independent of platform #simplify path with respect to /./ & /../ elements - independent of platform
#NOTE: "anomalies" in standard tcl processing on windows: #NOTE: "anomalies" in standard tcl processing on windows:
#e.g file normalize {//host} -> c:/host (or e.g d:/host if we happen to be on another volume) #e.g file normalize {//host} -> c:/host (or e.g d:/host if we happen to be on another volume)
@ -148,9 +148,9 @@ namespace eval punk::path {
#known issues: #known issues:
#1) #1)
# normjoin d://a//b//c -> d://a/b/c # normjoin d://a//b//c -> d://a/b/c
# This is because we don't detect specific schemes. ie it's treated the same as https://a/b/c -> https://a/b/c # This is because we don't detect specific schemes. ie it's treated the same as https://a/b/c -> https://a/b/c
# Not considered a problem - just potentially surprising. # Not considered a problem - just potentially surprising.
# To avoid it we would have to enumerate possible schemes. # To avoid it we would have to enumerate possible schemes.
# As it stands a unix system could define a 'scheme' that happens to match windows style driveletters. Consider a 'feature' ? review. # As it stands a unix system could define a 'scheme' that happens to match windows style driveletters. Consider a 'feature' ? review.
# won't fix? # won't fix?
#2) #2)
@ -164,16 +164,16 @@ namespace eval punk::path {
# normjoin ///server/share -> ///server/share # normjoin ///server/share -> ///server/share
#This is effectively an empty servername in the input with 'server' being pushed one level down - and the output is consistent #This is effectively an empty servername in the input with 'server' being pushed one level down - and the output is consistent
# possibly won't fix - review # possibly won't fix - review
#4) inconsistency #4) inconsistency
# we return normalized //server/share for //./UNC/server share # we return normalized //server/share for //./UNC/server share
# but other dos device paths are maintained # but other dos device paths are maintained
# e.g //./c:/etc # e.g //./c:/etc
# This is because such paths could contain alternate segment names (windows shortnames) which we aren't in a position to resolve. # This is because such paths could contain alternate segment names (windows shortnames) which we aren't in a position to resolve.
# caller should # caller should
# #as with 'case' below - caller will need to run a post 'file normalize' # #as with 'case' below - caller will need to run a post 'file normalize'
#5) we don't normalize case like file normalize does on windows platform. #5) we don't normalize case like file normalize does on windows platform.
# This is intentional. It could only be done with reference to underlying filesystem which we don't want here. # This is intentional. It could only be done with reference to underlying filesystem which we don't want here.
# #
# ================ # ================
# #
#relpaths all end up with leading . - while not always the simplest form, this is ok. (helps stop inadvertent conversions to absolutes) #relpaths all end up with leading . - while not always the simplest form, this is ok. (helps stop inadvertent conversions to absolutes)
@ -194,14 +194,14 @@ namespace eval punk::path {
/// { /// {
#if this is effectively //$emptyservername/ #if this is effectively //$emptyservername/
#then for consistency we should trail //<servername with a slash too? #then for consistency we should trail //<servername with a slash too?
#we can't transform to // or / #we can't transform to // or /
return /// return ///
#assert - code below should return /// (empty server prefix) for any number of leading slashes >=3 #assert - code below should return /// (empty server prefix) for any number of leading slashes >=3
#todo - shortcircuit that here? #todo - shortcircuit that here?
} }
} }
# /// # ///
set doubleslash1_posn [string first // $path] set doubleslash1_posn [string first // $path]
# -- --- --- temp warning on windows only - no x-platform difference in result # -- --- --- temp warning on windows only - no x-platform difference in result
#on windows //host is of type volumerelative #on windows //host is of type volumerelative
@ -221,7 +221,7 @@ namespace eval punk::path {
} }
# -- --- --- # -- --- ---
set is_relpath 0 set is_relpath 0
#set path [string map [list \\ /] $path] #set path [string map [list \\ /] $path]
set finalparts [list] set finalparts [list]
@ -264,11 +264,11 @@ namespace eval punk::path {
#normalize by dropping leading slash before split - and then treating first 2 segments as a root #normalize by dropping leading slash before split - and then treating first 2 segments as a root
#set parts [file split [string range $path 1 end]] #set parts [file split [string range $path 1 end]]
set parts [split $path /] set parts [split $path /]
#assert parts here has {} {} as first 2 entries #assert parts here has {} {} as first 2 entries
set rootindex 2 set rootindex 2
#currently prefer can backtrack to the //zipfs:/ scheme (below the mountpoint - to browse other mounts) #currently prefer can backtrack to the //zipfs:/ scheme (below the mountpoint - to browse other mounts)
#alternative handling for //zipfs:/path - don't go below mountpoint #alternative handling for //zipfs:/path - don't go below mountpoint
#but we can't determine just from string if mountpoint is direct subpath or a lower one e.g //zipfs:/arbitraryname/actualmountpoint #but we can't determine just from string if mountpoint is direct subpath or a lower one e.g //zipfs:/arbitraryname/actualmountpoint
#review - more generally //<mountmechanism>:/path ? #review - more generally //<mountmechanism>:/path ?
#todo - make an option for zipfs and others to determine the 'base' #todo - make an option for zipfs and others to determine the 'base'
#if {"zipfs:" eq [lindex $parts 2]} { #if {"zipfs:" eq [lindex $parts 2]} {
@ -281,7 +281,7 @@ namespace eval punk::path {
#set parts [file split $path] #set parts [file split $path]
set parts [::split $path /] set parts [::split $path /]
#e.g /a/b/c -> {} a b c #e.g /a/b/c -> {} a b c
#or relative path a/b/c -> a b c #or relative path a/b/c -> a b c
#or c:/a/b/c -> c: a b c #or c:/a/b/c -> c: a b c
if {[string match *: [lindex $parts 0]]} { if {[string match *: [lindex $parts 0]]} {
if {[lindex $parts 1] eq ""} { if {[lindex $parts 1] eq ""} {
@ -295,9 +295,9 @@ namespace eval punk::path {
} elseif {[lindex $parts 0] ne ""} { } elseif {[lindex $parts 0] ne ""} {
#relpath a/b/c #relpath a/b/c
set parts [linsert $parts 0 .] set parts [linsert $parts 0 .]
set rootindex 0 set rootindex 0
#allow backtracking arbitrarily for leading .. entries - simplify where possible #allow backtracking arbitrarily for leading .. entries - simplify where possible
#also need to stop possible conversion to absolute path #also need to stop possible conversion to absolute path
set is_relpath 1 set is_relpath 1
} }
} }
@ -306,7 +306,7 @@ namespace eval punk::path {
#puts stderr "-->baseparts:$baseparts" #puts stderr "-->baseparts:$baseparts"
#ensure that if our rootindex already spans a dotted segment (after the first one) we remove it #ensure that if our rootindex already spans a dotted segment (after the first one) we remove it
#must maintain initial . for relpaths to stop them converting to absolute via backtrack #must maintain initial . for relpaths to stop them converting to absolute via backtrack
# #
set finalparts [list [lindex $baseparts 0]] set finalparts [list [lindex $baseparts 0]]
foreach b [lrange $baseparts 1 end] { foreach b [lrange $baseparts 1 end] {
if {$b ni {. ..}} { if {$b ni {. ..}} {
@ -333,7 +333,7 @@ namespace eval punk::path {
lappend finalparts $p lappend finalparts $p
} }
} }
incr i incr i
} }
} else { } else {
foreach p [lrange $parts $rootindex+1 end] { foreach p [lrange $parts $rootindex+1 end] {
@ -345,7 +345,7 @@ namespace eval punk::path {
switch -exact -- $p { switch -exact -- $p {
. - "" {} . - "" {}
.. { .. {
lpop finalparts ;#uses punk::lib::compat::lpop if on < 8.7 lpop finalparts ;#uses punk::lib::compat::lpop if on < 8.7
} }
default { default {
lappend finalparts $p lappend finalparts $p
@ -403,16 +403,16 @@ namespace eval punk::path {
} }
#x-platform - punk::path::pathtype - can be used in safe interps - different concept of pathtypes to 'file pathtype' #x-platform - punk::path::pathtype - can be used in safe interps - different concept of pathtypes to 'file pathtype'
# - no volumerelative # - no volumerelative
# - no lookup of file volumes (volume is a windows concept - but with //zipfs:/ somewhat applicable to other platforms) # - no lookup of file volumes (volume is a windows concept - but with //zipfs:/ somewhat applicable to other platforms)
# - /* as absolute (covers also //zipfs:/ (volume), //server , //./etc , //./UNC) # - /* as absolute (covers also //zipfs:/ (volume), //server , //./etc , //./UNC)
# - xxx:// as absolute (scheme) # - xxx:// as absolute (scheme)
# - xxx:/ or x:/ as absolute # - xxx:/ or x:/ as absolute
# - x: xxx: -> as absolute (volume-basic or volume-extended) # - x: xxx: -> as absolute (volume-basic or volume-extended)
#note also on windows - legacy name for COM devices #note also on windows - legacy name for COM devices
# COM1 = COM1: # COM1 = COM1:
# //./COM1 ?? review # //./COM1 ?? review
proc pathtype {str} { proc pathtype {str} {
@ -425,7 +425,7 @@ namespace eval punk::path {
return absolute return absolute
} }
#only firstsegment with single colon at last position (after some non empty string) counts as volume or scheme - review #only firstsegment with single colon at last position (after some non empty string) counts as volume or scheme - review
#e.g a:b:/.. or a::/.. or :/.. is not treated as volume/scheme whereas ab:/ is. #e.g a:b:/.. or a::/.. or :/.. is not treated as volume/scheme whereas ab:/ is.
set firstslash [string first / $str] set firstslash [string first / $str]
if {$firstslash == -1} { if {$firstslash == -1} {
@ -434,9 +434,9 @@ namespace eval punk::path {
set firstsegment [string range $str 0 $firstslash-1] set firstsegment [string range $str 0 $firstslash-1]
} }
if {[set firstc [string first : $firstsegment]] > 0} { if {[set firstc [string first : $firstsegment]] > 0} {
set lhs_firstsegment [string range $firstsegment 0 $firstc-1] set lhs_firstsegment [string range $firstsegment 0 $firstc-1]
set rhs_firstsegment [string range $firstsegment $firstc+1 end] ;#exclude a:b/ etc set rhs_firstsegment [string range $firstsegment $firstc+1 end] ;#exclude a:b/ etc
if {$rhs_firstsegment eq ""} { if {$rhs_firstsegment eq ""} {
set rhs_entire_path [string range $str $firstc+1 end] set rhs_entire_path [string range $str $firstc+1 end]
#assert lhs_firstsegment not empty since firstc > 0 #assert lhs_firstsegment not empty since firstc > 0
#count following / sequence #count following / sequence
@ -466,7 +466,7 @@ namespace eval punk::path {
} }
} }
} }
#assert first element of any return has been absolute or relative #assert first element of any return has been absolute or relative
return relative return relative
} }
@ -489,7 +489,7 @@ namespace eval punk::path {
} }
return $str return $str
} }
#purely string based - no reference to filesystem knowledge #purely string based - no reference to filesystem knowledge
#unix-style forward slash only #unix-style forward slash only
proc plainjoin {args} { proc plainjoin {args} {
set args [lmap a $args {string map "\\\\ /" $a}] set args [lmap a $args {string map "\\\\ /" $a}]
@ -499,12 +499,12 @@ namespace eval punk::path {
set out "" set out ""
foreach a $args { foreach a $args {
if {![string length $out]} { if {![string length $out]} {
append out [plain $a] append out [plain $a]
} else { } else {
set a [plain $a] set a [plain $a]
if {[string map {/ ""} $out] eq ""} { if {[string map {/ ""} $out] eq ""} {
set out [string range $out 0 end-1] set out [string range $out 0 end-1]
} }
if {[string map {/ ""} $a] eq ""} { if {[string map {/ ""} $a] eq ""} {
#all / segment #all / segment
@ -512,16 +512,16 @@ namespace eval punk::path {
} else { } else {
if {[string length $a] > 2 && [string match "./*" $a]} { if {[string length $a] > 2 && [string match "./*" $a]} {
set a [string range $a 2 end] set a [string range $a 2 end]
} }
if {[string index $out end] eq "/"} { if {[string index $out end] eq "/"} {
append out $a append out $a
} else { } else {
append out / $a append out / $a
} }
} }
} }
} }
return $out return $out
} }
proc plainjoin1 {args} { proc plainjoin1 {args} {
if {[llength $args] == 1} { if {[llength $args] == 1} {
@ -530,9 +530,9 @@ namespace eval punk::path {
set out [trim_final_slash [lindex $args 0]] set out [trim_final_slash [lindex $args 0]]
foreach a [lrange $args 1 end] { foreach a [lrange $args 1 end] {
set a [trim_final_slash $a] set a [trim_final_slash $a]
append out / $a append out / $a
} }
return $out return $out
} }
#intention? #intention?
@ -554,13 +554,13 @@ namespace eval punk::path {
#*** !doctools #*** !doctools
#[call [fun pathglob_as_re] [arg pathglob]] #[call [fun pathglob_as_re] [arg pathglob]]
#[para] Returns a regular expression for matching a path to a glob pattern which can contain glob chars *|? in any segment of the path structure #[para] Returns a regular expression for matching a path to a glob pattern which can contain glob chars *|? in any segment of the path structure
#[para] ** matches any number of subdirectories. #[para] ** matches any number of subdirectories.
#[para] e.g /etc/**/*.txt will match any .txt files at any depth below /etc (except directly within /etc itself) #[para] e.g /etc/**/*.txt will match any .txt files at any depth below /etc (except directly within /etc itself)
#[para] e.g /etc/**.txt will match any .txt files at any depth below /etc #[para] e.g /etc/**.txt will match any .txt files at any depth below /etc
#[para] any segment that does not contain ** must match exactly one segment in the path #[para] any segment that does not contain ** must match exactly one segment in the path
#[para] e.g the glob /etc/*/*.doc - will match any .doc files that are exactly one tree level below /etc #[para] e.g the glob /etc/*/*.doc - will match any .doc files that are exactly one tree level below /etc
#[para] The pathglob doesn't have to contain glob characters, in which case the returned regex will match the pathglob exactly as specified. #[para] The pathglob doesn't have to contain glob characters, in which case the returned regex will match the pathglob exactly as specified.
#[para] Regular expression syntax is deliberateley not supported within the pathglob string so that supplied regex characters will be treated as literals #[para] Regular expression syntax is deliberateley not supported within the pathglob string so that supplied regex characters will be treated as literals
#todo - consider whether a way to escape the glob chars ? * is practical - to allow literals ? * #todo - consider whether a way to escape the glob chars ? * is practical - to allow literals ? *
@ -572,9 +572,9 @@ namespace eval punk::path {
} }
switch -- $seg { switch -- $seg {
* {lappend pats {[^/]*}} * {lappend pats {[^/]*}}
** {lappend pats {.*}} ** {lappend pats {.*}}
default { default {
set seg [string map [list {^ {\^} $ {\$} [} {\[} ( {\(} \{ \\\{ \\ {\\}] $seg] ;#treat regex characters in the input as literals set seg [string map [list {^ {\^} $ {\$} [} {\[} ( {\(} \{ \\\{ \\ {\\}] $seg] ;#treat regex characters in the input as literals
#set seg [string map [list . {[.]}] $seg] #set seg [string map [list . {[.]}] $seg]
set seg [string map {. [.]} $seg] set seg [string map {. [.]} $seg]
if {[regexp {[*?]} $seg]} { if {[regexp {[*?]} $seg]} {
@ -614,14 +614,14 @@ namespace eval punk::path {
} }
} }
} }
# -- --- --- --- --- --- # -- --- --- --- --- ---
set opt_nocase [dict get $opts -nocase] set opt_nocase [dict get $opts -nocase]
set explicit_nocase 1 ;#default to disprove set explicit_nocase 1 ;#default to disprove
if {$opt_nocase eq "\uFFFF"} { if {$opt_nocase eq "\uFFFF"} {
set opt_nocase 0 set opt_nocase 0
set explicit_nocase 0 set explicit_nocase 0
} }
# -- --- --- --- --- --- # -- --- --- --- --- ---
if {$opt_nocase} { if {$opt_nocase} {
return [regexp -nocase [pathglob_as_re $pathglob] $path] return [regexp -nocase [pathglob_as_re $pathglob] $path]
} else { } else {
@ -651,33 +651,33 @@ namespace eval punk::path {
-call-depth-internal -default 0 -type integer -call-depth-internal -default 0 -type integer
-antiglob_paths -default {} -help\ -antiglob_paths -default {} -help\
"list of path patterns to exclude "list of path patterns to exclude
may include * and ** path segments e.g may include * and ** path segments e.g
/usr/** (exlude subfolders based at /usr but not /usr/** (exlude subfolders based at /usr but not
files within /usr itself) files within /usr itself)
**/_aside (exlude files where _aside is last segment) **/_aside (exlude files where _aside is last segment)
**/_aside/* (exclude folders one below an _aside folder) **/_aside/* (exclude folders one below an _aside folder)
**/_aside/** (exclude all folders with _aside as a segment)" **/_aside/** (exclude all folders with _aside as a segment)"
@values -min 0 -max -1 -optional 1 -type string @values -min 0 -max -1 -optional 1 -type string
tailglobs -default * -multiple 1 -help\ tailglobs -default * -multiple 1 -help\
"Patterns to match against filename portion (last segment) of each file path "Patterns to match against filename portion (last segment) of each file path
within the directory tree being searched." within the directory tree being searched."
} }
#todo - implement treefiles which acts like dirfiles but allows path globbing in the same way as punk::ns::ns/ #todo - implement treefiles which acts like dirfiles but allows path globbing in the same way as punk::ns::ns/
#then review if treefiles can replace dirfiles or if both should exist (dirfiles can have literal glob chars in path segments - but that is a rare usecase) #then review if treefiles can replace dirfiles or if both should exist (dirfiles can have literal glob chars in path segments - but that is a rare usecase)
proc treefilenames {args} { proc treefilenames {args} {
#*** !doctools #*** !doctools
#[call [fun treefilenames] [opt {option value...}] [opt {globpattern...}]] #[call [fun treefilenames] [opt {option value...}] [opt {globpattern...}]]
#[para]basic (glob based) list of filenames matching each pattern in tailglobs - recursive #[para]basic (glob based) list of filenames matching each pattern in tailglobs - recursive
#[para] options: #[para] options:
#[para] [opt -dir] <path> #[para] [opt -dir] <path>
#[para] defaults to [lb]pwd[rb] - base path for tree to search #[para] defaults to [lb]pwd[rb] - base path for tree to search
#[para] [opt -antiglob_paths] <list> #[para] [opt -antiglob_paths] <list>
#[para] list of path patterns to exclude - may include * and ** path segments e.g /usr/** #[para] list of path patterns to exclude - may include * and ** path segments e.g /usr/**
#[para]no natsorting - so order is dependent on filesystem #[para]no natsorting - so order is dependent on filesystem
set argd [punk::args::parse $args withid ::punk::path::treefilenames] set argd [punk::args::parse $args withid ::punk::path::treefilenames]
lassign [dict values $argd] leaders opts values received lassign [dict values $argd] leaders opts values received
set tailglobs [dict get $values tailglobs] set tailglobs [dict get $values tailglobs]
# -- --- --- --- --- --- --- # -- --- --- --- --- --- ---
set opt_antiglob_paths [dict get $opts -antiglob_paths] set opt_antiglob_paths [dict get $opts -antiglob_paths]
@ -694,7 +694,7 @@ namespace eval punk::path {
set opt_dir [dict get $opts -directory] set opt_dir [dict get $opts -directory]
} }
if {![file isdirectory $opt_dir]} { if {![file isdirectory $opt_dir]} {
return [list] return [list]
} }
} else { } else {
#assume/require to exist in any recursive call #assume/require to exist in any recursive call
@ -713,15 +713,26 @@ namespace eval punk::path {
} }
#todo - account for vfs where matched path could appear to be a directory but is mounted so could be a desired match? #todo - account for vfs where matched path could appear to be a directory but is mounted so could be a desired match?
set dirfiles [lsort [glob -nocomplain -dir $opt_dir -type f {*}$tailglobs]] if {[catch {glob -nocomplain -dir $opt_dir -type f {*}$tailglobs} matches]} {
#we can get for example a permissions error
puts stderr "treefilenames error while listing files in dir $opt_dir\n $matches"
set dirfiles [list]
} else {
set dirfiles [lsort $matches]
}
lappend files {*}$dirfiles lappend files {*}$dirfiles
set dirdirs [glob -nocomplain -dir $opt_dir -type d *] if {[catch {glob -nocomplain -dir $opt_dir -type d *} dirdirs]} {
puts stderr "treefilenames error while listing subdirs in dir $opt_dir\n $dirdirs"
set dirdirs [list]
}
foreach dir $dirdirs { foreach dir $dirdirs {
set skip 0 set skip 0
foreach anti $opt_antiglob_paths { foreach anti $opt_antiglob_paths {
if {[globmatchpath $anti $dir]} { if {[globmatchpath $anti $dir]} {
set skip 1 set skip 1
break break
} }
} }
if {$skip} { if {$skip} {
@ -743,8 +754,8 @@ namespace eval punk::path {
#[item] #[item]
#[para] Arguments: #[para] Arguments:
# [list_begin arguments] # [list_begin arguments]
# [arg_def string reference] The path from which the relative path to location is determined. # [arg_def string reference] The path from which the relative path to location is determined.
# [arg_def string location] The location path which may be above or below the reference path # [arg_def string location] The location path which may be above or below the reference path
# [list_end] # [list_end]
#[item] #[item]
#[para] Results: #[para] Results:
@ -753,7 +764,7 @@ namespace eval punk::path {
#[item] #[item]
#[para] Notes: #[para] Notes:
#[para] Both paths must be the same type - ie both absolute or both relative #[para] Both paths must be the same type - ie both absolute or both relative
#[para] Case sensitive. ie punk::path::relative /etc /etC #[para] Case sensitive. ie punk::path::relative /etc /etC
# will return ../etC # will return ../etC
#[para] On windows, the drive-letter component (only) is not case sensitive #[para] On windows, the drive-letter component (only) is not case sensitive
#[example_begin] #[example_begin]
@ -774,7 +785,7 @@ namespace eval punk::path {
#[example_begin] #[example_begin]
# P% punk::path::relative /usr/local/etc/ /usr/local/etc/somewhere/below # P% punk::path::relative /usr/local/etc/ /usr/local/etc/somewhere/below
# - somewhere/below # - somewhere/below
# P% punk::path::relative /usr/local/etc/somewhere /usr/local/lib/here # P% punk::path::relative /usr/local/etc/somewhere /usr/local/lib/here
# - ../../lib/here # - ../../lib/here
#[example_end] #[example_end]
#[list_end] #[list_end]
@ -791,7 +802,7 @@ namespace eval punk::path {
#avoid normalizing if possible (file normalize *very* expensive on windows) #avoid normalizing if possible (file normalize *very* expensive on windows)
set do_normalize 0 set do_normalize 0
if {[file pathtype $reference] eq "relative"} { if {[file pathtype $reference] eq "relative"} {
#if reference is relative so is location #if reference is relative so is location
if {[regexp {[.]{2}} [list $reference $location]]} { if {[regexp {[.]{2}} [list $reference $location]]} {
set do_normalize 1 set do_normalize 1
} }
@ -857,7 +868,7 @@ namespace eval punk::path::lib {
namespace path [namespace parent] namespace path [namespace parent]
#*** !doctools #*** !doctools
#[subsection {Namespace punk::path::lib}] #[subsection {Namespace punk::path::lib}]
#[para] Secondary functions that are part of the API #[para] Secondary functions that are part of the API
#[list_begin definitions] #[list_begin definitions]
@ -877,17 +888,17 @@ namespace eval punk::path::lib {
namespace eval punk::path::system { namespace eval punk::path::system {
#*** !doctools #*** !doctools
#[subsection {Namespace punk::path::system}] #[subsection {Namespace punk::path::system}]
#[para] Internal functions that are not part of the API #[para] Internal functions that are not part of the API
} }
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready ## Ready
package provide punk::path [namespace eval punk::path { package provide punk::path [namespace eval punk::path {
variable pkg punk::path variable pkg punk::path
variable version variable version
set version 0.1.0 set version 0.1.0
}] }]
return return

31
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm
Unescape View File

@ -5974,13 +5974,40 @@ tcl::namespace::eval textblock {
[>punk . rhs]\ [>punk . rhs]\
[punk::lib::list_as_lines -- [lrepeat 8 " | "]] [punk::lib::list_as_lines -- [lrepeat 8 " | "]]
} }
punk::args::define [punk::lib::tstr -return string {
@id -id ::textblock::table
@cmd -name "textblock::table" -help\
"A wrapper for creating a textblock::class::table
NOTE: more options available - argument definition
is incomplete"
@opts
-return -choices {table tableobject}
-rows -type list -default "" -help\
"A list of lists.
Each toplevel element represents a row.
The number of elements in each row must
be the same.
e.g for 2 rows and 3 columns:
table -rows {{r0c0 r0c1 r0c2} {r1c0 r1c1 r1c2}}
"
-headers -type list -default "" -help\
"This is a simplified form where each column
has a single header row.
Each element in this list goes into the top
header row for a column.
More complex header arrangements where each
column has multiple headers can be made
by using -return tableobject and calling
$tableobj configure_column <idx> -headers"
}]
proc table {args} { proc table {args} {
#todo - use punk::args #todo - use punk::args
upvar ::textblock::class::opts_table_defaults toptdefaults upvar ::textblock::class::opts_table_defaults toptdefaults
set defaults [tcl::dict::create\ set defaults [tcl::dict::create\
-rows [list]\ -rows [list]\
-headers [list]\ -headers [list]\
-return string\ -return table\
] ]
@ -6017,7 +6044,7 @@ tcl::namespace::eval textblock {
if {$opt_return eq "string"} { if {$opt_return eq "table"} {
set result [$t print] set result [$t print]
$t destroy $t destroy
return $result return $result

5566
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.2.tm
View File

File diff suppressed because it is too large Load Diff

326
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm
Unescape View File

@ -331,26 +331,26 @@ tcl::namespace::eval punk::args {
parsing and help display. parsing and help display.
directives include: directives include:
%B%@id%N% ?opt val...? %B%@id%N% ?opt val...?
options: -id <str> spec-options: -id <str>
%B%@cmd%N% ?opt val...? %B%@cmd%N% ?opt val...?
options: -name <str> -help <str> spec-options: -name <str> -help <str>
%B%@leaders%N% ?opt val...? %B%@leaders%N% ?opt val...?
options: -min <int> -max <int> spec-options: -min <int> -max <int>
(used for leading args that come before switches/opts) (used for leading args that come before switches/opts)
%B%@opts%N% ?opt val...? %B%@opts%N% ?opt val...?
options: -any <bool> spec-options: -any <bool>
%B%@values%N% ?opt val...? %B%@values%N% ?opt val...?
options: -min <int> -max <int> spec-options: -min <int> -max <int>
(used for trailing args that come after switches/opts) (used for trailing args that come after switches/opts)
%B%@argdisplay%N% ?opt val...? %B%@argdisplay%N% ?opt val...?
options: -header <str> (text for header row of table) spec-options: -header <str> (text for header row of table)
-body <str> (text to replace autogenerated arg info) -body <str> (text to replace autogenerated arg info)
%B%@doc%N% ?opt val...? %B%@doc%N% ?opt val...?
options: -name <str> -url <str> spec-options: -name <str> -url <str>
%B%@seealso%N% ?opt val...? %B%@seealso%N% ?opt val...?
options: -name <str> -url <str> (for footer - unimplemented) spec-options: -name <str> -url <str> (for footer - unimplemented)
Some other options normally present on custom arguments are available Some other spec-options normally present on custom arguments are available
to use with the @leaders @opts @values directives to set defaults to use with the @leaders @opts @values directives to set defaults
for subsequent lines that represent your custom arguments. for subsequent lines that represent your custom arguments.
These directives should occur in exactly this order - but can be These directives should occur in exactly this order - but can be
@ -361,7 +361,12 @@ tcl::namespace::eval punk::args {
or using the i <cmd>.. function - an @id with -id <value> is needed. or using the i <cmd>.. function - an @id with -id <value> is needed.
All directives can be omitted, in which case every line represents All directives can be omitted, in which case every line represents
a custom value or option. a custom leader, value or option.
All will be leaders by default if no options defined.
If options are defined (by naming with leading dash, or explicitly
specifying @opts) then the definitions prior to the options will be
categorised as leaders, and those following the options will be
categorised as values.
Custom arguments are defined by using any word at the start of a Custom arguments are defined by using any word at the start of a
line that doesn't begin with @ or - line that doesn't begin with @ or -
@ -369,7 +374,7 @@ tcl::namespace::eval punk::args {
that @@somearg becomes an argument named @somearg) that @@somearg becomes an argument named @somearg)
custom leading args, switches/options (names starting with -) custom leading args, switches/options (names starting with -)
and trailing values also take options: and trailing values also take spec-options:
-type <typename> -type <typename>
defaults to string. If no other restrictions defaults to string. If no other restrictions
@ -397,12 +402,22 @@ tcl::namespace::eval punk::args {
-optional <boolean> -optional <boolean>
(defaults to true for flags/switches false otherwise) (defaults to true for flags/switches false otherwise)
For non flag/switch arguments - all arguments with
-optional true must sit consecutively within their group.
ie all optional leader arguments must be together, and all
optional value arguments must be together. Furthermore,
specifying both optional leaders and optional values will
often lead to ambiguous parsing results. Currently, all
optional non-flg/switch arguments should be either at the
trailing end of leaders or the trailing end of values.
Further unambiguous arrangements of optional args may be
made in future - but are currently considered 'unsupported'
-default <value> -default <value>
-multiple <bool> (for leaders & values defines whether -multiple <bool> (for leaders & values defines whether
subsequent received values are stored agains the same subsequent received values are stored against the same
argument name - only applies to final leader or value) argument name - only applies to final leader OR final value)
(for options/flags this allows the opt-val pair or solo (for options/flags this allows the opt-val pair or solo
flag to appear multiple times - no necessarily contiguously) flag to appear multiple times - not necessarily contiguously)
-choices {<choicelist>} -choices {<choicelist>}
A list of allowable values for an argument. A list of allowable values for an argument.
The -default value doesn't have to be in the list. The -default value doesn't have to be in the list.
@ -438,7 +453,7 @@ tcl::namespace::eval punk::args {
Max of -1 represents no upper limit. Max of -1 represents no upper limit.
If <range> allows more than one choice the value is a list If <range> allows more than one choice the value is a list
consisting of items in the choices made available through consisting of items in the choices made available through
entries in -choices/-choicegrups. entries in -choices/-choicegroups.
-minsize (type dependant) -minsize (type dependant)
-maxsize (type dependant) -maxsize (type dependant)
-range (type dependant) -range (type dependant)
@ -1667,6 +1682,7 @@ tcl::namespace::eval punk::args {
" "
@leaders -min 0 -max 0 @leaders -min 0 -max 0
@opts @opts
-return -default text -choices {text dict}
-form -default 0 -help\ -form -default 0 -help\
"Ordinal index or name of command form" "Ordinal index or name of command form"
@ -1694,7 +1710,7 @@ tcl::namespace::eval punk::args {
(directives are lines beginning with (directives are lines beginning with
@ e.g @id, @cmd etc) @ e.g @id, @cmd etc)
if -type is @leaders,@opts or @values matches from that type if -type is leaders,opts or values matches from that type
will be returned. will be returned.
if -type is another directive such as @id, @doc etc the if -type is another directive such as @id, @doc etc the
@ -1706,8 +1722,10 @@ tcl::namespace::eval punk::args {
proc resolved_def {args} { proc resolved_def {args} {
#not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only.
set opts [dict create\ set opts [dict create\
-types {}\ -return text\
-types {}\
-form 0\ -form 0\
-antiglobs {}\ -antiglobs {}\
-override {}\ -override {}\
@ -1743,7 +1761,7 @@ tcl::namespace::eval punk::args {
} }
dict for {k v} $opts { dict for {k v} $opts {
switch -- $k { switch -- $k {
-form - -types - -antiglobs - -override {} -return - -form - -types - -antiglobs - -override {}
default { default {
punk::args::parse $args withid ::punk::args::resolved_def punk::args::parse $args withid ::punk::args::resolved_def
return return
@ -1764,163 +1782,185 @@ tcl::namespace::eval punk::args {
variable id_cache_rawdef variable id_cache_rawdef
set realid [real_id $id] set realid [real_id $id]
if {$realid eq ""} {
return
}
if {$realid ne ""} { set deflist [tcl::dict::get $id_cache_rawdef $realid]
set deflist [tcl::dict::get $id_cache_rawdef $realid] set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]]
set result ""
set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]]
set opt_form [dict get $opts -form] set opt_form [dict get $opts -form]
if {[string is integer -strict $opt_form]} { if {[string is integer -strict $opt_form]} {
set formname [lindex [dict get $specdict form_names] $opt_form] set formname [lindex [dict get $specdict form_names] $opt_form]
} else { } else {
set formname $opt_form set formname $opt_form
} }
set opt_override [dict get $opts -override] set opt_override [dict get $opts -override]
set opt_return [dict get $opts -return]
#set arg_info [dict get $specdict ARG_INFO]
set arg_info [dict get $specdict FORMS $formname ARG_INFO] #set arg_info [dict get $specdict ARG_INFO]
set argtypes [dict create leaders leader opts option values value] set arg_info [dict get $specdict FORMS $formname ARG_INFO]
set argtypes [dict create leaders leader opts option values value]
set opt_antiglobs [dict get $opts -antiglobs]
set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] set opt_antiglobs [dict get $opts -antiglobs]
set suppressed_directives [list] set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *]
set suppressed_args [list] set suppressed_directives [list]
foreach ag $opt_antiglobs { set suppressed_args [list]
foreach d $directives { foreach ag $opt_antiglobs {
if {[string match $ag $d]} { foreach d $directives {
lappend suppressed_directives $d if {[string match $ag $d]} {
} lappend suppressed_directives $d
} }
foreach argname [dict keys $arg_info] { }
if {[string match $ag $argname]} { foreach argname [dict keys $arg_info] {
lappend suppressed_args $argname if {[string match $ag $argname]} {
} lappend suppressed_args $argname
} }
} }
set suppressed_directives [lsort -unique $suppressed_directives] }
set suppressed_args [lsort -unique $suppressed_args] set suppressed_directives [lsort -unique $suppressed_directives]
set suppressed_args [lsort -unique $suppressed_args]
set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives]
set globbed [list] set globbed [list]
foreach pat $patterns { foreach pat $patterns {
set matches [dict keys $arg_info $pat] set matches [dict keys $arg_info $pat]
lappend globbed {*}$matches lappend globbed {*}$matches
} }
set globbed [lsort -unique $globbed] set globbed [lsort -unique $globbed]
set included_args [punk::args::system::punklib_ldiff $globbed $suppressed_args] set included_args [punk::args::system::punklib_ldiff $globbed $suppressed_args]
foreach type $typelist {
switch -exact -- $type {
* {
if {"@id" in $included_directives} {
if {[dict exists $opt_override @id]} {
append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]"
} else {
append result \n "@id -id [dict get $specdict id]"
}
}
foreach directive {@package @cmd @doc @seealso @argdisplay} {
set dshort [string range $directive 1 end]
if {"$directive" in $included_directives} {
if {[dict exists $opt_override $directive]} {
append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]"
} else {
append result \n "$directive [dict get $specdict ${dshort}_info]"
}
}
}
#output ordered by leader, option, value
foreach pseudodirective {leaders opts values} tp {leader option value} {
set directive "@$pseudodirective"
switch -- $directive {
@leaders {set defaults_key leaderspec_defaults}
@opts {set defaults_key optspec_defaults}
@values {set defaults_key valspec_defaults}
}
if {"$directive" in $included_directives} {
if {[dict exists $opt_override "$directive"]} {
append result \n "$directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]"
} else {
append result \n "$directive [dict get $specdict $defaults_key]"
}
}
if {$pseudodirective in $included_directives} { set result ""
foreach m $included_args { set resultdict [dict create]
set argspec [dict get $arg_info $m] foreach type $typelist {
if {[dict get $argspec -ARGTYPE] eq $tp} { switch -exact -- $type {
set argspec [dict remove $argspec -ARGTYPE] * {
if {[dict exists $opt_override $m]} { if {"@id" in $included_directives} {
append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" if {[dict exists $opt_override @id]} {
} else { append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]"
append result \n "$m $argspec" dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]
} } else {
} append result \n "@id -id [dict get $specdict id]"
} dict set resultdict @id [list -id [dict get $specdict id]]
}
} }
} }
@id { foreach directive {@package @cmd @doc @seealso @argdisplay} {
if {"@id" in $included_directives} { set dshort [string range $directive 1 end]
#only a single id record can exist if {"$directive" in $included_directives} {
if {[dict exists $opt_override @id]} { if {[dict exists $opt_override $directive]} {
append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]"
dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]
} else { } else {
append result \n "@id -id [dict get $specdict id]" append result \n "$directive [dict get $specdict ${dshort}_info]"
dict set resultdict $directive [dict get $specdict ${dshort}_info]
} }
} }
} }
@package - @cmd - @doc - @seealso - @argdisplay { #output ordered by leader, option, value
if {"$type" in $included_directives} { foreach pseudodirective {leaders opts values} tp {leader option value} {
set tp [string range $type 1 end] ;# @package -> package set directive "@$pseudodirective"
if {[dict exists $opt_override $type]} { switch -- $directive {
append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" @leaders {set defaults_key leaderspec_defaults}
} else { @opts {set defaults_key optspec_defaults}
append result \n "$type [dict get $specdict ${tp}_info]" @values {set defaults_key valspec_defaults}
}
} }
}
@leaders - @opts - @values { if {"$directive" in $included_directives} {
#these are the active defaults for further arguments if {[dict exists $opt_override "$directive"]} {
if {"$type" in $included_directives} { append result \n "$directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]"
switch -- $type { dict set resultdict $directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]
@leaders {set defaults_key leaderspec_defaults}
@opts {set defaults_key optspec_defaults}
@values {set defaults_key valspec_defaults}
}
if {[dict exists $opt_override $type]} {
append result \n "$type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]]"
} else { } else {
append result \n "$type [dict get $specdict leaderspec_defaults]" append result \n "$directive [dict get $specdict $defaults_key]"
dict set resultdict $directive [dict get $specdict $defaults_key]
} }
} }
}
leaders - opts - values { if {$pseudodirective in $included_directives} {
#pseudo-directives
if {$type in $included_directives} {
foreach m $included_args { foreach m $included_args {
set argspec [dict get $arg_info $m] set argspec [dict get $arg_info $m]
if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { if {[dict get $argspec -ARGTYPE] eq $tp} {
set argspec [dict remove $argspec -ARGTYPE] set argspec [dict remove $argspec -ARGTYPE]
if {[dict exists $opt_override $m]} { if {[dict exists $opt_override $m]} {
append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" append result \n "$m [dict merge $argspec [dict get $opt_override $m]]"
dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]]
} else { } else {
append result \n "$m $argspec" append result \n "$m $argspec"
dict set resultdict $m $argspec
} }
} }
} }
} }
} }
default {
}
@id {
if {"@id" in $included_directives} {
#only a single id record can exist
if {[dict exists $opt_override @id]} {
append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]"
dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]
} else {
append result \n "@id -id [dict get $specdict id]"
dict set resultdict @id [list -id [dict get $specdict id]]
}
} }
} }
@package - @cmd - @doc - @seealso - @argdisplay {
if {"$type" in $included_directives} {
set tp [string range $type 1 end] ;# @package -> package
if {[dict exists $opt_override $type]} {
append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]"
dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]
} else {
append result \n "$type [dict get $specdict ${tp}_info]"
dict set resultdict $type [dict get $specdict ${tp}_info]
}
}
}
@leaders - @opts - @values {
#these are the active defaults for further arguments
if {"$type" in $included_directives} {
switch -- $type {
@leaders {set defaults_key leaderspec_defaults}
@opts {set defaults_key optspec_defaults}
@values {set defaults_key valspec_defaults}
}
if {[dict exists $opt_override $type]} {
append result \n "$type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]]"
dict set resultdict $type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]]
} else {
append result \n "$type [dict get $specdict leaderspec_defaults]"
dict set resultdict $type [dict get $specdict leaderspec_defaults]
}
}
}
leaders - opts - values {
#pseudo-directives
if {$type in $included_directives} {
foreach m $included_args {
set argspec [dict get $arg_info $m]
if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} {
set argspec [dict remove $argspec -ARGTYPE]
if {[dict exists $opt_override $m]} {
append result \n "$m [dict merge $argspec [dict get $opt_override $m]]"
dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]]
} else {
append result \n "$m $argspec"
dict set resultdict $m $argspec
}
}
}
}
}
default {
}
}
if {$opt_return eq "text"} {
return $result
} else {
return $resultdict
} }
return $result
} }
} }

153
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm
Unescape View File

@ -20,7 +20,7 @@
#[manpage_begin punkshell_module_punk::path 0 0.1.0] #[manpage_begin punkshell_module_punk::path 0 0.1.0]
#[copyright "2023"] #[copyright "2023"]
#[titledesc {Filesystem path utilities}] [comment {-- Name section and table of contents description --}] #[titledesc {Filesystem path utilities}] [comment {-- Name section and table of contents description --}]
#[moddesc {punk path filesystem utils}] [comment {-- Description at end of page heading --}] #[moddesc {punk path filesystem utils}] [comment {-- Description at end of page heading --}]
#[require punk::path] #[require punk::path]
#[description] #[description]
#[keywords module path filesystem] #[keywords module path filesystem]
@ -104,21 +104,21 @@ namespace eval punk::path {
#*** !doctools #*** !doctools
#[subsection {Namespace punk::path}] #[subsection {Namespace punk::path}]
#[para] Core API functions for punk::path #[para] Core API functions for punk::path
#[list_begin definitions] #[list_begin definitions]
# -- --- # -- ---
#punk::path::normjoin #punk::path::normjoin
# - simplify . and .. segments as far as possible whilst respecting specific types of root. # - simplify . and .. segments as far as possible whilst respecting specific types of root.
# -- --- # -- ---
#a form of file normalize that supports //xxx to be treated as server path names #a form of file normalize that supports //xxx to be treated as server path names
#(ie regardless of unices ignoring (generally) leading double slashes, and regardless of windows volumerelative path syntax) #(ie regardless of unices ignoring (generally) leading double slashes, and regardless of windows volumerelative path syntax)
#(sometimes //server.com used as a short form for urls - which doesn't seem too incompatible with this anyway) #(sometimes //server.com used as a short form for urls - which doesn't seem too incompatible with this anyway)
# -- --- # -- ---
#This is intended to be purely a string analysis - without reference to filesystem volumes or vfs or zipfs mountpoints etc #This is intended to be purely a string analysis - without reference to filesystem volumes or vfs or zipfs mountpoints etc
# #
#TODO - option for caller to provide a -base below which we can't backtrack. #TODO - option for caller to provide a -base below which we can't backtrack.
#This is preferable to setting policy here for example regarding forcing no trackback below //servername/share #This is preferable to setting policy here for example regarding forcing no trackback below //servername/share
#Our default is to allow trackback to: #Our default is to allow trackback to:
# <scheme>://<something> # <scheme>://<something>
# <driveletter>:/ # <driveletter>:/
@ -128,7 +128,7 @@ namespace eval punk::path {
# ./../<repeated> - (track back indefinitely on relpath as we are not resolving to anything physical and can't fully simplify the leading backtracks) # ./../<repeated> - (track back indefinitely on relpath as we are not resolving to anything physical and can't fully simplify the leading backtracks)
# #
#The caller should do the file/vfs operations to determine this - not us. #The caller should do the file/vfs operations to determine this - not us.
# -- --- # -- ---
#simplify path with respect to /./ & /../ elements - independent of platform #simplify path with respect to /./ & /../ elements - independent of platform
#NOTE: "anomalies" in standard tcl processing on windows: #NOTE: "anomalies" in standard tcl processing on windows:
#e.g file normalize {//host} -> c:/host (or e.g d:/host if we happen to be on another volume) #e.g file normalize {//host} -> c:/host (or e.g d:/host if we happen to be on another volume)
@ -148,9 +148,9 @@ namespace eval punk::path {
#known issues: #known issues:
#1) #1)
# normjoin d://a//b//c -> d://a/b/c # normjoin d://a//b//c -> d://a/b/c
# This is because we don't detect specific schemes. ie it's treated the same as https://a/b/c -> https://a/b/c # This is because we don't detect specific schemes. ie it's treated the same as https://a/b/c -> https://a/b/c
# Not considered a problem - just potentially surprising. # Not considered a problem - just potentially surprising.
# To avoid it we would have to enumerate possible schemes. # To avoid it we would have to enumerate possible schemes.
# As it stands a unix system could define a 'scheme' that happens to match windows style driveletters. Consider a 'feature' ? review. # As it stands a unix system could define a 'scheme' that happens to match windows style driveletters. Consider a 'feature' ? review.
# won't fix? # won't fix?
#2) #2)
@ -164,16 +164,16 @@ namespace eval punk::path {
# normjoin ///server/share -> ///server/share # normjoin ///server/share -> ///server/share
#This is effectively an empty servername in the input with 'server' being pushed one level down - and the output is consistent #This is effectively an empty servername in the input with 'server' being pushed one level down - and the output is consistent
# possibly won't fix - review # possibly won't fix - review
#4) inconsistency #4) inconsistency
# we return normalized //server/share for //./UNC/server share # we return normalized //server/share for //./UNC/server share
# but other dos device paths are maintained # but other dos device paths are maintained
# e.g //./c:/etc # e.g //./c:/etc
# This is because such paths could contain alternate segment names (windows shortnames) which we aren't in a position to resolve. # This is because such paths could contain alternate segment names (windows shortnames) which we aren't in a position to resolve.
# caller should # caller should
# #as with 'case' below - caller will need to run a post 'file normalize' # #as with 'case' below - caller will need to run a post 'file normalize'
#5) we don't normalize case like file normalize does on windows platform. #5) we don't normalize case like file normalize does on windows platform.
# This is intentional. It could only be done with reference to underlying filesystem which we don't want here. # This is intentional. It could only be done with reference to underlying filesystem which we don't want here.
# #
# ================ # ================
# #
#relpaths all end up with leading . - while not always the simplest form, this is ok. (helps stop inadvertent conversions to absolutes) #relpaths all end up with leading . - while not always the simplest form, this is ok. (helps stop inadvertent conversions to absolutes)
@ -194,14 +194,14 @@ namespace eval punk::path {
/// { /// {
#if this is effectively //$emptyservername/ #if this is effectively //$emptyservername/
#then for consistency we should trail //<servername with a slash too? #then for consistency we should trail //<servername with a slash too?
#we can't transform to // or / #we can't transform to // or /
return /// return ///
#assert - code below should return /// (empty server prefix) for any number of leading slashes >=3 #assert - code below should return /// (empty server prefix) for any number of leading slashes >=3
#todo - shortcircuit that here? #todo - shortcircuit that here?
} }
} }
# /// # ///
set doubleslash1_posn [string first // $path] set doubleslash1_posn [string first // $path]
# -- --- --- temp warning on windows only - no x-platform difference in result # -- --- --- temp warning on windows only - no x-platform difference in result
#on windows //host is of type volumerelative #on windows //host is of type volumerelative
@ -221,7 +221,7 @@ namespace eval punk::path {
} }
# -- --- --- # -- --- ---
set is_relpath 0 set is_relpath 0
#set path [string map [list \\ /] $path] #set path [string map [list \\ /] $path]
set finalparts [list] set finalparts [list]
@ -264,11 +264,11 @@ namespace eval punk::path {
#normalize by dropping leading slash before split - and then treating first 2 segments as a root #normalize by dropping leading slash before split - and then treating first 2 segments as a root
#set parts [file split [string range $path 1 end]] #set parts [file split [string range $path 1 end]]
set parts [split $path /] set parts [split $path /]
#assert parts here has {} {} as first 2 entries #assert parts here has {} {} as first 2 entries
set rootindex 2 set rootindex 2
#currently prefer can backtrack to the //zipfs:/ scheme (below the mountpoint - to browse other mounts) #currently prefer can backtrack to the //zipfs:/ scheme (below the mountpoint - to browse other mounts)
#alternative handling for //zipfs:/path - don't go below mountpoint #alternative handling for //zipfs:/path - don't go below mountpoint
#but we can't determine just from string if mountpoint is direct subpath or a lower one e.g //zipfs:/arbitraryname/actualmountpoint #but we can't determine just from string if mountpoint is direct subpath or a lower one e.g //zipfs:/arbitraryname/actualmountpoint
#review - more generally //<mountmechanism>:/path ? #review - more generally //<mountmechanism>:/path ?
#todo - make an option for zipfs and others to determine the 'base' #todo - make an option for zipfs and others to determine the 'base'
#if {"zipfs:" eq [lindex $parts 2]} { #if {"zipfs:" eq [lindex $parts 2]} {
@ -281,7 +281,7 @@ namespace eval punk::path {
#set parts [file split $path] #set parts [file split $path]
set parts [::split $path /] set parts [::split $path /]
#e.g /a/b/c -> {} a b c #e.g /a/b/c -> {} a b c
#or relative path a/b/c -> a b c #or relative path a/b/c -> a b c
#or c:/a/b/c -> c: a b c #or c:/a/b/c -> c: a b c
if {[string match *: [lindex $parts 0]]} { if {[string match *: [lindex $parts 0]]} {
if {[lindex $parts 1] eq ""} { if {[lindex $parts 1] eq ""} {
@ -295,9 +295,9 @@ namespace eval punk::path {
} elseif {[lindex $parts 0] ne ""} { } elseif {[lindex $parts 0] ne ""} {
#relpath a/b/c #relpath a/b/c
set parts [linsert $parts 0 .] set parts [linsert $parts 0 .]
set rootindex 0 set rootindex 0
#allow backtracking arbitrarily for leading .. entries - simplify where possible #allow backtracking arbitrarily for leading .. entries - simplify where possible
#also need to stop possible conversion to absolute path #also need to stop possible conversion to absolute path
set is_relpath 1 set is_relpath 1
} }
} }
@ -306,7 +306,7 @@ namespace eval punk::path {
#puts stderr "-->baseparts:$baseparts" #puts stderr "-->baseparts:$baseparts"
#ensure that if our rootindex already spans a dotted segment (after the first one) we remove it #ensure that if our rootindex already spans a dotted segment (after the first one) we remove it
#must maintain initial . for relpaths to stop them converting to absolute via backtrack #must maintain initial . for relpaths to stop them converting to absolute via backtrack
# #
set finalparts [list [lindex $baseparts 0]] set finalparts [list [lindex $baseparts 0]]
foreach b [lrange $baseparts 1 end] { foreach b [lrange $baseparts 1 end] {
if {$b ni {. ..}} { if {$b ni {. ..}} {
@ -333,7 +333,7 @@ namespace eval punk::path {
lappend finalparts $p lappend finalparts $p
} }
} }
incr i incr i
} }
} else { } else {
foreach p [lrange $parts $rootindex+1 end] { foreach p [lrange $parts $rootindex+1 end] {
@ -345,7 +345,7 @@ namespace eval punk::path {
switch -exact -- $p { switch -exact -- $p {
. - "" {} . - "" {}
.. { .. {
lpop finalparts ;#uses punk::lib::compat::lpop if on < 8.7 lpop finalparts ;#uses punk::lib::compat::lpop if on < 8.7
} }
default { default {
lappend finalparts $p lappend finalparts $p
@ -403,16 +403,16 @@ namespace eval punk::path {
} }
#x-platform - punk::path::pathtype - can be used in safe interps - different concept of pathtypes to 'file pathtype' #x-platform - punk::path::pathtype - can be used in safe interps - different concept of pathtypes to 'file pathtype'
# - no volumerelative # - no volumerelative
# - no lookup of file volumes (volume is a windows concept - but with //zipfs:/ somewhat applicable to other platforms) # - no lookup of file volumes (volume is a windows concept - but with //zipfs:/ somewhat applicable to other platforms)
# - /* as absolute (covers also //zipfs:/ (volume), //server , //./etc , //./UNC) # - /* as absolute (covers also //zipfs:/ (volume), //server , //./etc , //./UNC)
# - xxx:// as absolute (scheme) # - xxx:// as absolute (scheme)
# - xxx:/ or x:/ as absolute # - xxx:/ or x:/ as absolute
# - x: xxx: -> as absolute (volume-basic or volume-extended) # - x: xxx: -> as absolute (volume-basic or volume-extended)
#note also on windows - legacy name for COM devices #note also on windows - legacy name for COM devices
# COM1 = COM1: # COM1 = COM1:
# //./COM1 ?? review # //./COM1 ?? review
proc pathtype {str} { proc pathtype {str} {
@ -425,7 +425,7 @@ namespace eval punk::path {
return absolute return absolute
} }
#only firstsegment with single colon at last position (after some non empty string) counts as volume or scheme - review #only firstsegment with single colon at last position (after some non empty string) counts as volume or scheme - review
#e.g a:b:/.. or a::/.. or :/.. is not treated as volume/scheme whereas ab:/ is. #e.g a:b:/.. or a::/.. or :/.. is not treated as volume/scheme whereas ab:/ is.
set firstslash [string first / $str] set firstslash [string first / $str]
if {$firstslash == -1} { if {$firstslash == -1} {
@ -434,9 +434,9 @@ namespace eval punk::path {
set firstsegment [string range $str 0 $firstslash-1] set firstsegment [string range $str 0 $firstslash-1]
} }
if {[set firstc [string first : $firstsegment]] > 0} { if {[set firstc [string first : $firstsegment]] > 0} {
set lhs_firstsegment [string range $firstsegment 0 $firstc-1] set lhs_firstsegment [string range $firstsegment 0 $firstc-1]
set rhs_firstsegment [string range $firstsegment $firstc+1 end] ;#exclude a:b/ etc set rhs_firstsegment [string range $firstsegment $firstc+1 end] ;#exclude a:b/ etc
if {$rhs_firstsegment eq ""} { if {$rhs_firstsegment eq ""} {
set rhs_entire_path [string range $str $firstc+1 end] set rhs_entire_path [string range $str $firstc+1 end]
#assert lhs_firstsegment not empty since firstc > 0 #assert lhs_firstsegment not empty since firstc > 0
#count following / sequence #count following / sequence
@ -466,7 +466,7 @@ namespace eval punk::path {
} }
} }
} }
#assert first element of any return has been absolute or relative #assert first element of any return has been absolute or relative
return relative return relative
} }
@ -489,7 +489,7 @@ namespace eval punk::path {
} }
return $str return $str
} }
#purely string based - no reference to filesystem knowledge #purely string based - no reference to filesystem knowledge
#unix-style forward slash only #unix-style forward slash only
proc plainjoin {args} { proc plainjoin {args} {
set args [lmap a $args {string map "\\\\ /" $a}] set args [lmap a $args {string map "\\\\ /" $a}]
@ -499,12 +499,12 @@ namespace eval punk::path {
set out "" set out ""
foreach a $args { foreach a $args {
if {![string length $out]} { if {![string length $out]} {
append out [plain $a] append out [plain $a]
} else { } else {
set a [plain $a] set a [plain $a]
if {[string map {/ ""} $out] eq ""} { if {[string map {/ ""} $out] eq ""} {
set out [string range $out 0 end-1] set out [string range $out 0 end-1]
} }
if {[string map {/ ""} $a] eq ""} { if {[string map {/ ""} $a] eq ""} {
#all / segment #all / segment
@ -512,16 +512,16 @@ namespace eval punk::path {
} else { } else {
if {[string length $a] > 2 && [string match "./*" $a]} { if {[string length $a] > 2 && [string match "./*" $a]} {
set a [string range $a 2 end] set a [string range $a 2 end]
} }
if {[string index $out end] eq "/"} { if {[string index $out end] eq "/"} {
append out $a append out $a
} else { } else {
append out / $a append out / $a
} }
} }
} }
} }
return $out return $out
} }
proc plainjoin1 {args} { proc plainjoin1 {args} {
if {[llength $args] == 1} { if {[llength $args] == 1} {
@ -530,9 +530,9 @@ namespace eval punk::path {
set out [trim_final_slash [lindex $args 0]] set out [trim_final_slash [lindex $args 0]]
foreach a [lrange $args 1 end] { foreach a [lrange $args 1 end] {
set a [trim_final_slash $a] set a [trim_final_slash $a]
append out / $a append out / $a
} }
return $out return $out
} }
#intention? #intention?
@ -554,13 +554,13 @@ namespace eval punk::path {
#*** !doctools #*** !doctools
#[call [fun pathglob_as_re] [arg pathglob]] #[call [fun pathglob_as_re] [arg pathglob]]
#[para] Returns a regular expression for matching a path to a glob pattern which can contain glob chars *|? in any segment of the path structure #[para] Returns a regular expression for matching a path to a glob pattern which can contain glob chars *|? in any segment of the path structure
#[para] ** matches any number of subdirectories. #[para] ** matches any number of subdirectories.
#[para] e.g /etc/**/*.txt will match any .txt files at any depth below /etc (except directly within /etc itself) #[para] e.g /etc/**/*.txt will match any .txt files at any depth below /etc (except directly within /etc itself)
#[para] e.g /etc/**.txt will match any .txt files at any depth below /etc #[para] e.g /etc/**.txt will match any .txt files at any depth below /etc
#[para] any segment that does not contain ** must match exactly one segment in the path #[para] any segment that does not contain ** must match exactly one segment in the path
#[para] e.g the glob /etc/*/*.doc - will match any .doc files that are exactly one tree level below /etc #[para] e.g the glob /etc/*/*.doc - will match any .doc files that are exactly one tree level below /etc
#[para] The pathglob doesn't have to contain glob characters, in which case the returned regex will match the pathglob exactly as specified. #[para] The pathglob doesn't have to contain glob characters, in which case the returned regex will match the pathglob exactly as specified.
#[para] Regular expression syntax is deliberateley not supported within the pathglob string so that supplied regex characters will be treated as literals #[para] Regular expression syntax is deliberateley not supported within the pathglob string so that supplied regex characters will be treated as literals
#todo - consider whether a way to escape the glob chars ? * is practical - to allow literals ? * #todo - consider whether a way to escape the glob chars ? * is practical - to allow literals ? *
@ -572,9 +572,9 @@ namespace eval punk::path {
} }
switch -- $seg { switch -- $seg {
* {lappend pats {[^/]*}} * {lappend pats {[^/]*}}
** {lappend pats {.*}} ** {lappend pats {.*}}
default { default {
set seg [string map [list {^ {\^} $ {\$} [} {\[} ( {\(} \{ \\\{ \\ {\\}] $seg] ;#treat regex characters in the input as literals set seg [string map [list {^ {\^} $ {\$} [} {\[} ( {\(} \{ \\\{ \\ {\\}] $seg] ;#treat regex characters in the input as literals
#set seg [string map [list . {[.]}] $seg] #set seg [string map [list . {[.]}] $seg]
set seg [string map {. [.]} $seg] set seg [string map {. [.]} $seg]
if {[regexp {[*?]} $seg]} { if {[regexp {[*?]} $seg]} {
@ -614,14 +614,14 @@ namespace eval punk::path {
} }
} }
} }
# -- --- --- --- --- --- # -- --- --- --- --- ---
set opt_nocase [dict get $opts -nocase] set opt_nocase [dict get $opts -nocase]
set explicit_nocase 1 ;#default to disprove set explicit_nocase 1 ;#default to disprove
if {$opt_nocase eq "\uFFFF"} { if {$opt_nocase eq "\uFFFF"} {
set opt_nocase 0 set opt_nocase 0
set explicit_nocase 0 set explicit_nocase 0
} }
# -- --- --- --- --- --- # -- --- --- --- --- ---
if {$opt_nocase} { if {$opt_nocase} {
return [regexp -nocase [pathglob_as_re $pathglob] $path] return [regexp -nocase [pathglob_as_re $pathglob] $path]
} else { } else {
@ -651,33 +651,33 @@ namespace eval punk::path {
-call-depth-internal -default 0 -type integer -call-depth-internal -default 0 -type integer
-antiglob_paths -default {} -help\ -antiglob_paths -default {} -help\
"list of path patterns to exclude "list of path patterns to exclude
may include * and ** path segments e.g may include * and ** path segments e.g
/usr/** (exlude subfolders based at /usr but not /usr/** (exlude subfolders based at /usr but not
files within /usr itself) files within /usr itself)
**/_aside (exlude files where _aside is last segment) **/_aside (exlude files where _aside is last segment)
**/_aside/* (exclude folders one below an _aside folder) **/_aside/* (exclude folders one below an _aside folder)
**/_aside/** (exclude all folders with _aside as a segment)" **/_aside/** (exclude all folders with _aside as a segment)"
@values -min 0 -max -1 -optional 1 -type string @values -min 0 -max -1 -optional 1 -type string
tailglobs -default * -multiple 1 -help\ tailglobs -default * -multiple 1 -help\
"Patterns to match against filename portion (last segment) of each file path "Patterns to match against filename portion (last segment) of each file path
within the directory tree being searched." within the directory tree being searched."
} }
#todo - implement treefiles which acts like dirfiles but allows path globbing in the same way as punk::ns::ns/ #todo - implement treefiles which acts like dirfiles but allows path globbing in the same way as punk::ns::ns/
#then review if treefiles can replace dirfiles or if both should exist (dirfiles can have literal glob chars in path segments - but that is a rare usecase) #then review if treefiles can replace dirfiles or if both should exist (dirfiles can have literal glob chars in path segments - but that is a rare usecase)
proc treefilenames {args} { proc treefilenames {args} {
#*** !doctools #*** !doctools
#[call [fun treefilenames] [opt {option value...}] [opt {globpattern...}]] #[call [fun treefilenames] [opt {option value...}] [opt {globpattern...}]]
#[para]basic (glob based) list of filenames matching each pattern in tailglobs - recursive #[para]basic (glob based) list of filenames matching each pattern in tailglobs - recursive
#[para] options: #[para] options:
#[para] [opt -dir] <path> #[para] [opt -dir] <path>
#[para] defaults to [lb]pwd[rb] - base path for tree to search #[para] defaults to [lb]pwd[rb] - base path for tree to search
#[para] [opt -antiglob_paths] <list> #[para] [opt -antiglob_paths] <list>
#[para] list of path patterns to exclude - may include * and ** path segments e.g /usr/** #[para] list of path patterns to exclude - may include * and ** path segments e.g /usr/**
#[para]no natsorting - so order is dependent on filesystem #[para]no natsorting - so order is dependent on filesystem
set argd [punk::args::parse $args withid ::punk::path::treefilenames] set argd [punk::args::parse $args withid ::punk::path::treefilenames]
lassign [dict values $argd] leaders opts values received lassign [dict values $argd] leaders opts values received
set tailglobs [dict get $values tailglobs] set tailglobs [dict get $values tailglobs]
# -- --- --- --- --- --- --- # -- --- --- --- --- --- ---
set opt_antiglob_paths [dict get $opts -antiglob_paths] set opt_antiglob_paths [dict get $opts -antiglob_paths]
@ -694,7 +694,7 @@ namespace eval punk::path {
set opt_dir [dict get $opts -directory] set opt_dir [dict get $opts -directory]
} }
if {![file isdirectory $opt_dir]} { if {![file isdirectory $opt_dir]} {
return [list] return [list]
} }
} else { } else {
#assume/require to exist in any recursive call #assume/require to exist in any recursive call
@ -713,15 +713,26 @@ namespace eval punk::path {
} }
#todo - account for vfs where matched path could appear to be a directory but is mounted so could be a desired match? #todo - account for vfs where matched path could appear to be a directory but is mounted so could be a desired match?
set dirfiles [lsort [glob -nocomplain -dir $opt_dir -type f {*}$tailglobs]] if {[catch {glob -nocomplain -dir $opt_dir -type f {*}$tailglobs} matches]} {
#we can get for example a permissions error
puts stderr "treefilenames error while listing files in dir $opt_dir\n $matches"
set dirfiles [list]
} else {
set dirfiles [lsort $matches]
}
lappend files {*}$dirfiles lappend files {*}$dirfiles
set dirdirs [glob -nocomplain -dir $opt_dir -type d *] if {[catch {glob -nocomplain -dir $opt_dir -type d *} dirdirs]} {
puts stderr "treefilenames error while listing subdirs in dir $opt_dir\n $dirdirs"
set dirdirs [list]
}
foreach dir $dirdirs { foreach dir $dirdirs {
set skip 0 set skip 0
foreach anti $opt_antiglob_paths { foreach anti $opt_antiglob_paths {
if {[globmatchpath $anti $dir]} { if {[globmatchpath $anti $dir]} {
set skip 1 set skip 1
break break
} }
} }
if {$skip} { if {$skip} {
@ -743,8 +754,8 @@ namespace eval punk::path {
#[item] #[item]
#[para] Arguments: #[para] Arguments:
# [list_begin arguments] # [list_begin arguments]
# [arg_def string reference] The path from which the relative path to location is determined. # [arg_def string reference] The path from which the relative path to location is determined.
# [arg_def string location] The location path which may be above or below the reference path # [arg_def string location] The location path which may be above or below the reference path
# [list_end] # [list_end]
#[item] #[item]
#[para] Results: #[para] Results:
@ -753,7 +764,7 @@ namespace eval punk::path {
#[item] #[item]
#[para] Notes: #[para] Notes:
#[para] Both paths must be the same type - ie both absolute or both relative #[para] Both paths must be the same type - ie both absolute or both relative
#[para] Case sensitive. ie punk::path::relative /etc /etC #[para] Case sensitive. ie punk::path::relative /etc /etC
# will return ../etC # will return ../etC
#[para] On windows, the drive-letter component (only) is not case sensitive #[para] On windows, the drive-letter component (only) is not case sensitive
#[example_begin] #[example_begin]
@ -774,7 +785,7 @@ namespace eval punk::path {
#[example_begin] #[example_begin]
# P% punk::path::relative /usr/local/etc/ /usr/local/etc/somewhere/below # P% punk::path::relative /usr/local/etc/ /usr/local/etc/somewhere/below
# - somewhere/below # - somewhere/below
# P% punk::path::relative /usr/local/etc/somewhere /usr/local/lib/here # P% punk::path::relative /usr/local/etc/somewhere /usr/local/lib/here
# - ../../lib/here # - ../../lib/here
#[example_end] #[example_end]
#[list_end] #[list_end]
@ -791,7 +802,7 @@ namespace eval punk::path {
#avoid normalizing if possible (file normalize *very* expensive on windows) #avoid normalizing if possible (file normalize *very* expensive on windows)
set do_normalize 0 set do_normalize 0
if {[file pathtype $reference] eq "relative"} { if {[file pathtype $reference] eq "relative"} {
#if reference is relative so is location #if reference is relative so is location
if {[regexp {[.]{2}} [list $reference $location]]} { if {[regexp {[.]{2}} [list $reference $location]]} {
set do_normalize 1 set do_normalize 1
} }
@ -857,7 +868,7 @@ namespace eval punk::path::lib {
namespace path [namespace parent] namespace path [namespace parent]
#*** !doctools #*** !doctools
#[subsection {Namespace punk::path::lib}] #[subsection {Namespace punk::path::lib}]
#[para] Secondary functions that are part of the API #[para] Secondary functions that are part of the API
#[list_begin definitions] #[list_begin definitions]
@ -877,17 +888,17 @@ namespace eval punk::path::lib {
namespace eval punk::path::system { namespace eval punk::path::system {
#*** !doctools #*** !doctools
#[subsection {Namespace punk::path::system}] #[subsection {Namespace punk::path::system}]
#[para] Internal functions that are not part of the API #[para] Internal functions that are not part of the API
} }
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready ## Ready
package provide punk::path [namespace eval punk::path { package provide punk::path [namespace eval punk::path {
variable pkg punk::path variable pkg punk::path
variable version variable version
set version 0.1.0 set version 0.1.0
}] }]
return return

31
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm
Unescape View File

@ -5974,13 +5974,40 @@ tcl::namespace::eval textblock {
[>punk . rhs]\ [>punk . rhs]\
[punk::lib::list_as_lines -- [lrepeat 8 " | "]] [punk::lib::list_as_lines -- [lrepeat 8 " | "]]
} }
punk::args::define [punk::lib::tstr -return string {
@id -id ::textblock::table
@cmd -name "textblock::table" -help\
"A wrapper for creating a textblock::class::table
NOTE: more options available - argument definition
is incomplete"
@opts
-return -choices {table tableobject}
-rows -type list -default "" -help\
"A list of lists.
Each toplevel element represents a row.
The number of elements in each row must
be the same.
e.g for 2 rows and 3 columns:
table -rows {{r0c0 r0c1 r0c2} {r1c0 r1c1 r1c2}}
"
-headers -type list -default "" -help\
"This is a simplified form where each column
has a single header row.
Each element in this list goes into the top
header row for a column.
More complex header arrangements where each
column has multiple headers can be made
by using -return tableobject and calling
$tableobj configure_column <idx> -headers"
}]
proc table {args} { proc table {args} {
#todo - use punk::args #todo - use punk::args
upvar ::textblock::class::opts_table_defaults toptdefaults upvar ::textblock::class::opts_table_defaults toptdefaults
set defaults [tcl::dict::create\ set defaults [tcl::dict::create\
-rows [list]\ -rows [list]\
-headers [list]\ -headers [list]\
-return string\ -return table\
] ]
@ -6017,7 +6044,7 @@ tcl::namespace::eval textblock {
if {$opt_return eq "string"} { if {$opt_return eq "table"} {
set result [$t print] set result [$t print]
$t destroy $t destroy
return $result return $result

5566
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/tomlish-1.1.2.tm
View File

File diff suppressed because it is too large Load Diff

5566
src/vendormodules/tomlish-1.1.2.tm
View File

File diff suppressed because it is too large Load Diff
Write Preview
Loading…
Cancel
Save