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

tomlish and punk::netbox improvements

master
Julian Noble 1 week 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
Split 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.
directives include:
%B%@id%N% ?opt val...?
options: -id <str>
spec-options: -id <str>
%B%@cmd%N% ?opt val...?
options: -name <str> -help <str>
spec-options: -name <str> -help <str>
%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)
%B%@opts%N% ?opt val...?
options: -any <bool>
spec-options: -any <bool>
%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)
%B%@argdisplay%N% ?opt val...?
options: -header <str> (text for header row of table)
-body <str> (text to replace autogenerated arg info)
spec-options: -header <str> (text for header row of table)
-body <str> (text to replace autogenerated arg info)
%B%@doc%N% ?opt val...?
options: -name <str> -url <str>
spec-options: -name <str> -url <str>
%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
for subsequent lines that represent your custom arguments.
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.
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
line that doesn't begin with @ or -
@ -369,7 +374,7 @@ tcl::namespace::eval punk::args {
that @@somearg becomes an argument named @somearg)
custom leading args, switches/options (names starting with -)
and trailing values also take options:
and trailing values also take spec-options:
-type <typename>
defaults to string. If no other restrictions
@ -397,12 +402,22 @@ tcl::namespace::eval punk::args {
-optional <boolean>
(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>
-multiple <bool> (for leaders & values defines whether
subsequent received values are stored agains the same
argument name - only applies to final leader or value)
subsequent received values are stored against the same
argument name - only applies to final leader OR final value)
(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>}
A list of allowable values for an argument.
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.
If <range> allows more than one choice the value is a list
consisting of items in the choices made available through
entries in -choices/-choicegrups.
entries in -choices/-choicegroups.
-minsize (type dependant)
-maxsize (type dependant)
-range (type dependant)
@ -1667,6 +1682,7 @@ tcl::namespace::eval punk::args {
"
@leaders -min 0 -max 0
@opts
-return -default text -choices {text dict}
-form -default 0 -help\
"Ordinal index or name of command form"
@ -1694,7 +1710,7 @@ tcl::namespace::eval punk::args {
(directives are lines beginning with
@ 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.
if -type is another directive such as @id, @doc etc the
@ -1706,8 +1722,10 @@ tcl::namespace::eval punk::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\
-types {}\
-return text\
-types {}\
-form 0\
-antiglobs {}\
-override {}\
@ -1743,7 +1761,7 @@ tcl::namespace::eval punk::args {
}
dict for {k v} $opts {
switch -- $k {
-form - -types - -antiglobs - -override {}
-return - -form - -types - -antiglobs - -override {}
default {
punk::args::parse $args withid ::punk::args::resolved_def
return
@ -1764,163 +1782,185 @@ tcl::namespace::eval punk::args {
variable id_cache_rawdef
set realid [real_id $id]
if {$realid eq ""} {
return
}
if {$realid ne ""} {
set deflist [tcl::dict::get $id_cache_rawdef $realid]
set result ""
set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]]
set deflist [tcl::dict::get $id_cache_rawdef $realid]
set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]]
set opt_form [dict get $opts -form]
if {[string is integer -strict $opt_form]} {
set formname [lindex [dict get $specdict form_names] $opt_form]
} else {
set formname $opt_form
}
set opt_override [dict get $opts -override]
#set arg_info [dict get $specdict ARG_INFO]
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 suppressed_directives [list]
set suppressed_args [list]
foreach ag $opt_antiglobs {
foreach d $directives {
if {[string match $ag $d]} {
lappend suppressed_directives $d
}
set opt_form [dict get $opts -form]
if {[string is integer -strict $opt_form]} {
set formname [lindex [dict get $specdict form_names] $opt_form]
} else {
set formname $opt_form
}
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 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 suppressed_directives [list]
set suppressed_args [list]
foreach ag $opt_antiglobs {
foreach d $directives {
if {[string match $ag $d]} {
lappend suppressed_directives $d
}
foreach argname [dict keys $arg_info] {
if {[string match $ag $argname]} {
lappend suppressed_args $argname
}
}
foreach argname [dict keys $arg_info] {
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]
foreach pat $patterns {
set matches [dict keys $arg_info $pat]
lappend globbed {*}$matches
}
set globbed [lsort -unique $globbed]
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]"
}
}
set globbed [list]
foreach pat $patterns {
set matches [dict keys $arg_info $pat]
lappend globbed {*}$matches
}
set globbed [lsort -unique $globbed]
set included_args [punk::args::system::punklib_ldiff $globbed $suppressed_args]
if {$pseudodirective in $included_directives} {
foreach m $included_args {
set argspec [dict get $arg_info $m]
if {[dict get $argspec -ARGTYPE] eq $tp} {
set argspec [dict remove $argspec -ARGTYPE]
if {[dict exists $opt_override $m]} {
append result \n "$m [dict merge $argspec [dict get $opt_override $m]]"
} else {
append result \n "$m $argspec"
}
}
}
}
set result ""
set resultdict [dict create]
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]]"
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 {
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]]"
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]]"
dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]
} 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 {
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]]"
} else {
append result \n "$type [dict get $specdict ${tp}_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}
}
}
@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]]"
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]]"
dict set resultdict $directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]
} 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 {
#pseudo-directives
if {$type in $included_directives} {
if {$pseudodirective in $included_directives} {
foreach m $included_args {
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]
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 {
}
@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]
#[copyright "2023"]
#[titledesc {Filesystem path utilities}] [comment {-- Name section and table of contents description --}]
#[moddesc {punk path filesystem utils}] [comment {-- Description at end of page heading --}]
#[moddesc {punk path filesystem utils}] [comment {-- Description at end of page heading --}]
#[require punk::path]
#[description]
#[keywords module path filesystem]
@ -104,21 +104,21 @@ namespace eval punk::path {
#*** !doctools
#[subsection {Namespace punk::path}]
#[para] Core API functions for punk::path
#[para] Core API functions for punk::path
#[list_begin definitions]
# -- ---
# -- ---
#punk::path::normjoin
# - 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
#(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
#
#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:
# <scheme>://<something>
# <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)
#
#The caller should do the file/vfs operations to determine this - not us.
# -- ---
# -- ---
#simplify path with respect to /./ & /../ elements - independent of platform
#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)
@ -148,9 +148,9 @@ namespace eval punk::path {
#known issues:
#1)
# 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.
# 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.
# won't fix?
#2)
@ -164,16 +164,16 @@ namespace eval punk::path {
# 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
# possibly won't fix - review
#4) inconsistency
#4) inconsistency
# we return normalized //server/share for //./UNC/server share
# but other dos device paths are maintained
# 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.
# caller should
# #as with 'case' below - caller will need to run a post 'file normalize'
# caller should
# #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.
# 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)
@ -194,14 +194,14 @@ namespace eval punk::path {
/// {
#if this is effectively //$emptyservername/
#then for consistency we should trail //<servername with a slash too?
#we can't transform to // or /
#we can't transform to // or /
return ///
#assert - code below should return /// (empty server prefix) for any number of leading slashes >=3
#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
#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 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
#set parts [file split [string range $path 1 end]]
set parts [split $path /]
#assert parts here has {} {} as first 2 entries
#assert parts here has {} {} as first 2 entries
set rootindex 2
#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
#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 ?
#todo - make an option for zipfs and others to determine the 'base'
#if {"zipfs:" eq [lindex $parts 2]} {
@ -281,7 +281,7 @@ namespace eval punk::path {
#set parts [file split $path]
set parts [::split $path /]
#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
if {[string match *: [lindex $parts 0]]} {
if {[lindex $parts 1] eq ""} {
@ -295,9 +295,9 @@ namespace eval punk::path {
} elseif {[lindex $parts 0] ne ""} {
#relpath a/b/c
set parts [linsert $parts 0 .]
set rootindex 0
#allow backtracking arbitrarily for leading .. entries - simplify where possible
#also need to stop possible conversion to absolute path
set rootindex 0
#allow backtracking arbitrarily for leading .. entries - simplify where possible
#also need to stop possible conversion to absolute path
set is_relpath 1
}
}
@ -306,7 +306,7 @@ namespace eval punk::path {
#puts stderr "-->baseparts:$baseparts"
#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
#
#
set finalparts [list [lindex $baseparts 0]]
foreach b [lrange $baseparts 1 end] {
if {$b ni {. ..}} {
@ -333,7 +333,7 @@ namespace eval punk::path {
lappend finalparts $p
}
}
incr i
incr i
}
} else {
foreach p [lrange $parts $rootindex+1 end] {
@ -345,7 +345,7 @@ namespace eval punk::path {
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 {
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'
# - no volumerelative
#x-platform - punk::path::pathtype - can be used in safe interps - different concept of pathtypes to 'file pathtype'
# - no volumerelative
# - 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)
# - xxx:// as absolute (scheme)
# - 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
# COM1 = COM1:
# COM1 = COM1:
# //./COM1 ?? review
proc pathtype {str} {
@ -425,7 +425,7 @@ namespace eval punk::path {
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.
set firstslash [string first / $str]
if {$firstslash == -1} {
@ -434,9 +434,9 @@ namespace eval punk::path {
set firstsegment [string range $str 0 $firstslash-1]
}
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
if {$rhs_firstsegment eq ""} {
if {$rhs_firstsegment eq ""} {
set rhs_entire_path [string range $str $firstc+1 end]
#assert lhs_firstsegment not empty since firstc > 0
#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
}
@ -489,7 +489,7 @@ namespace eval punk::path {
}
return $str
}
#purely string based - no reference to filesystem knowledge
#purely string based - no reference to filesystem knowledge
#unix-style forward slash only
proc plainjoin {args} {
set args [lmap a $args {string map "\\\\ /" $a}]
@ -499,12 +499,12 @@ namespace eval punk::path {
set out ""
foreach a $args {
if {![string length $out]} {
append out [plain $a]
append out [plain $a]
} else {
set a [plain $a]
if {[string map {/ ""} $out] eq ""} {
set out [string range $out 0 end-1]
}
}
if {[string map {/ ""} $a] eq ""} {
#all / segment
@ -512,16 +512,16 @@ namespace eval punk::path {
} else {
if {[string length $a] > 2 && [string match "./*" $a]} {
set a [string range $a 2 end]
}
}
if {[string index $out end] eq "/"} {
append out $a
} else {
append out / $a
append out / $a
}
}
}
}
return $out
return $out
}
proc plainjoin1 {args} {
if {[llength $args] == 1} {
@ -530,9 +530,9 @@ namespace eval punk::path {
set out [trim_final_slash [lindex $args 0]]
foreach a [lrange $args 1 end] {
set a [trim_final_slash $a]
append out / $a
append out / $a
}
return $out
return $out
}
#intention?
@ -554,13 +554,13 @@ namespace eval punk::path {
#*** !doctools
#[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] ** 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
#[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] 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 ? *
@ -572,9 +572,9 @@ namespace eval punk::path {
}
switch -- $seg {
* {lappend pats {[^/]*}}
** {lappend pats {.*}}
** {lappend pats {.*}}
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 {. [.]} $seg]
if {[regexp {[*?]} $seg]} {
@ -614,14 +614,14 @@ namespace eval punk::path {
}
}
}
# -- --- --- --- --- ---
# -- --- --- --- --- ---
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"} {
set opt_nocase 0
set explicit_nocase 0
}
# -- --- --- --- --- ---
}
# -- --- --- --- --- ---
if {$opt_nocase} {
return [regexp -nocase [pathglob_as_re $pathglob] $path]
} else {
@ -651,33 +651,33 @@ namespace eval punk::path {
-call-depth-internal -default 0 -type integer
-antiglob_paths -default {} -help\
"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
files within /usr itself)
**/_aside (exlude files where _aside is last segment)
**/_aside/* (exclude folders one below an _aside folder)
**/_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\
"Patterns to match against filename portion (last segment) of each file path
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)
proc treefilenames {args} {
#*** !doctools
#[call [fun treefilenames] [opt {option value...}] [opt {globpattern...}]]
#[para]basic (glob based) list of filenames matching each pattern in tailglobs - recursive
#[para] options:
#[para] [opt -dir] <path>
#[para] [opt -dir] <path>
#[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]no natsorting - so order is dependent on filesystem
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 opt_antiglob_paths [dict get $opts -antiglob_paths]
@ -694,7 +694,7 @@ namespace eval punk::path {
set opt_dir [dict get $opts -directory]
}
if {![file isdirectory $opt_dir]} {
return [list]
return [list]
}
} else {
#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?
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
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 {
set skip 0
foreach anti $opt_antiglob_paths {
if {[globmatchpath $anti $dir]} {
set skip 1
break
break
}
}
if {$skip} {
@ -743,8 +754,8 @@ namespace eval punk::path {
#[item]
#[para] Arguments:
# [list_begin arguments]
# [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 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
# [list_end]
#[item]
#[para] Results:
@ -753,7 +764,7 @@ namespace eval punk::path {
#[item]
#[para] Notes:
#[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
#[para] On windows, the drive-letter component (only) is not case sensitive
#[example_begin]
@ -774,7 +785,7 @@ namespace eval punk::path {
#[example_begin]
# P% punk::path::relative /usr/local/etc/ /usr/local/etc/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
#[example_end]
#[list_end]
@ -791,7 +802,7 @@ namespace eval punk::path {
#avoid normalizing if possible (file normalize *very* expensive on windows)
set do_normalize 0
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]]} {
set do_normalize 1
}
@ -857,7 +868,7 @@ namespace eval punk::path::lib {
namespace path [namespace parent]
#*** !doctools
#[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]
@ -877,17 +888,17 @@ namespace eval punk::path::lib {
namespace eval punk::path::system {
#*** !doctools
#[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 {
variable pkg punk::path
variable version
set version 0.1.0
set version 0.1.0
}]
return

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

@ -5974,13 +5974,40 @@ tcl::namespace::eval textblock {
[>punk . rhs]\
[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} {
#todo - use punk::args
upvar ::textblock::class::opts_table_defaults toptdefaults
set defaults [tcl::dict::create\
-rows [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]
$t destroy
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.
directives include:
%B%@id%N% ?opt val...?
options: -id <str>
spec-options: -id <str>
%B%@cmd%N% ?opt val...?
options: -name <str> -help <str>
spec-options: -name <str> -help <str>
%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)
%B%@opts%N% ?opt val...?
options: -any <bool>
spec-options: -any <bool>
%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)
%B%@argdisplay%N% ?opt val...?
options: -header <str> (text for header row of table)
-body <str> (text to replace autogenerated arg info)
spec-options: -header <str> (text for header row of table)
-body <str> (text to replace autogenerated arg info)
%B%@doc%N% ?opt val...?
options: -name <str> -url <str>
spec-options: -name <str> -url <str>
%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
for subsequent lines that represent your custom arguments.
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.
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
line that doesn't begin with @ or -
@ -369,7 +374,7 @@ tcl::namespace::eval punk::args {
that @@somearg becomes an argument named @somearg)
custom leading args, switches/options (names starting with -)
and trailing values also take options:
and trailing values also take spec-options:
-type <typename>
defaults to string. If no other restrictions
@ -397,12 +402,22 @@ tcl::namespace::eval punk::args {
-optional <boolean>
(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>
-multiple <bool> (for leaders & values defines whether
subsequent received values are stored agains the same
argument name - only applies to final leader or value)
subsequent received values are stored against the same
argument name - only applies to final leader OR final value)
(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>}
A list of allowable values for an argument.
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.
If <range> allows more than one choice the value is a list
consisting of items in the choices made available through
entries in -choices/-choicegrups.
entries in -choices/-choicegroups.
-minsize (type dependant)
-maxsize (type dependant)
-range (type dependant)
@ -1667,6 +1682,7 @@ tcl::namespace::eval punk::args {
"
@leaders -min 0 -max 0
@opts
-return -default text -choices {text dict}
-form -default 0 -help\
"Ordinal index or name of command form"
@ -1694,7 +1710,7 @@ tcl::namespace::eval punk::args {
(directives are lines beginning with
@ 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.
if -type is another directive such as @id, @doc etc the
@ -1706,8 +1722,10 @@ tcl::namespace::eval punk::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\
-types {}\
-return text\
-types {}\
-form 0\
-antiglobs {}\
-override {}\
@ -1743,7 +1761,7 @@ tcl::namespace::eval punk::args {
}
dict for {k v} $opts {
switch -- $k {
-form - -types - -antiglobs - -override {}
-return - -form - -types - -antiglobs - -override {}
default {
punk::args::parse $args withid ::punk::args::resolved_def
return
@ -1764,163 +1782,185 @@ tcl::namespace::eval punk::args {
variable id_cache_rawdef
set realid [real_id $id]
if {$realid eq ""} {
return
}
if {$realid ne ""} {
set deflist [tcl::dict::get $id_cache_rawdef $realid]
set result ""
set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]]
set deflist [tcl::dict::get $id_cache_rawdef $realid]
set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]]
set opt_form [dict get $opts -form]
if {[string is integer -strict $opt_form]} {
set formname [lindex [dict get $specdict form_names] $opt_form]
} else {
set formname $opt_form
}
set opt_override [dict get $opts -override]
#set arg_info [dict get $specdict ARG_INFO]
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 suppressed_directives [list]
set suppressed_args [list]
foreach ag $opt_antiglobs {
foreach d $directives {
if {[string match $ag $d]} {
lappend suppressed_directives $d
}
set opt_form [dict get $opts -form]
if {[string is integer -strict $opt_form]} {
set formname [lindex [dict get $specdict form_names] $opt_form]
} else {
set formname $opt_form
}
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 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 suppressed_directives [list]
set suppressed_args [list]
foreach ag $opt_antiglobs {
foreach d $directives {
if {[string match $ag $d]} {
lappend suppressed_directives $d
}
foreach argname [dict keys $arg_info] {
if {[string match $ag $argname]} {
lappend suppressed_args $argname
}
}
foreach argname [dict keys $arg_info] {
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]
foreach pat $patterns {
set matches [dict keys $arg_info $pat]
lappend globbed {*}$matches
}
set globbed [lsort -unique $globbed]
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]"
}
}
set globbed [list]
foreach pat $patterns {
set matches [dict keys $arg_info $pat]
lappend globbed {*}$matches
}
set globbed [lsort -unique $globbed]
set included_args [punk::args::system::punklib_ldiff $globbed $suppressed_args]
if {$pseudodirective in $included_directives} {
foreach m $included_args {
set argspec [dict get $arg_info $m]
if {[dict get $argspec -ARGTYPE] eq $tp} {
set argspec [dict remove $argspec -ARGTYPE]
if {[dict exists $opt_override $m]} {
append result \n "$m [dict merge $argspec [dict get $opt_override $m]]"
} else {
append result \n "$m $argspec"
}
}
}
}
set result ""
set resultdict [dict create]
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]]"
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 {
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]]"
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]]"
dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]
} 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 {
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]]"
} else {
append result \n "$type [dict get $specdict ${tp}_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}
}
}
@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]]"
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]]"
dict set resultdict $directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]
} 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 {
#pseudo-directives
if {$type in $included_directives} {
if {$pseudodirective in $included_directives} {
foreach m $included_args {
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]
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 {
}
@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]
#[copyright "2023"]
#[titledesc {Filesystem path utilities}] [comment {-- Name section and table of contents description --}]
#[moddesc {punk path filesystem utils}] [comment {-- Description at end of page heading --}]
#[moddesc {punk path filesystem utils}] [comment {-- Description at end of page heading --}]
#[require punk::path]
#[description]
#[keywords module path filesystem]
@ -104,21 +104,21 @@ namespace eval punk::path {
#*** !doctools
#[subsection {Namespace punk::path}]
#[para] Core API functions for punk::path
#[para] Core API functions for punk::path
#[list_begin definitions]
# -- ---
# -- ---
#punk::path::normjoin
# - 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
#(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
#
#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:
# <scheme>://<something>
# <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)
#
#The caller should do the file/vfs operations to determine this - not us.
# -- ---
# -- ---
#simplify path with respect to /./ & /../ elements - independent of platform
#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)
@ -148,9 +148,9 @@ namespace eval punk::path {
#known issues:
#1)
# 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.
# 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.
# won't fix?
#2)
@ -164,16 +164,16 @@ namespace eval punk::path {
# 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
# possibly won't fix - review
#4) inconsistency
#4) inconsistency
# we return normalized //server/share for //./UNC/server share
# but other dos device paths are maintained
# 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.
# caller should
# #as with 'case' below - caller will need to run a post 'file normalize'
# caller should
# #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.
# 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)
@ -194,14 +194,14 @@ namespace eval punk::path {
/// {
#if this is effectively //$emptyservername/
#then for consistency we should trail //<servername with a slash too?
#we can't transform to // or /
#we can't transform to // or /
return ///
#assert - code below should return /// (empty server prefix) for any number of leading slashes >=3
#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
#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 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
#set parts [file split [string range $path 1 end]]
set parts [split $path /]
#assert parts here has {} {} as first 2 entries
#assert parts here has {} {} as first 2 entries
set rootindex 2
#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
#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 ?
#todo - make an option for zipfs and others to determine the 'base'
#if {"zipfs:" eq [lindex $parts 2]} {
@ -281,7 +281,7 @@ namespace eval punk::path {
#set parts [file split $path]
set parts [::split $path /]
#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
if {[string match *: [lindex $parts 0]]} {
if {[lindex $parts 1] eq ""} {
@ -295,9 +295,9 @@ namespace eval punk::path {
} elseif {[lindex $parts 0] ne ""} {
#relpath a/b/c
set parts [linsert $parts 0 .]
set rootindex 0
#allow backtracking arbitrarily for leading .. entries - simplify where possible
#also need to stop possible conversion to absolute path
set rootindex 0
#allow backtracking arbitrarily for leading .. entries - simplify where possible
#also need to stop possible conversion to absolute path
set is_relpath 1
}
}
@ -306,7 +306,7 @@ namespace eval punk::path {
#puts stderr "-->baseparts:$baseparts"
#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
#
#
set finalparts [list [lindex $baseparts 0]]
foreach b [lrange $baseparts 1 end] {
if {$b ni {. ..}} {
@ -333,7 +333,7 @@ namespace eval punk::path {
lappend finalparts $p
}
}
incr i
incr i
}
} else {
foreach p [lrange $parts $rootindex+1 end] {
@ -345,7 +345,7 @@ namespace eval punk::path {
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 {
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'
# - no volumerelative
#x-platform - punk::path::pathtype - can be used in safe interps - different concept of pathtypes to 'file pathtype'
# - no volumerelative
# - 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)
# - xxx:// as absolute (scheme)
# - 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
# COM1 = COM1:
# COM1 = COM1:
# //./COM1 ?? review
proc pathtype {str} {
@ -425,7 +425,7 @@ namespace eval punk::path {
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.
set firstslash [string first / $str]
if {$firstslash == -1} {
@ -434,9 +434,9 @@ namespace eval punk::path {
set firstsegment [string range $str 0 $firstslash-1]
}
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
if {$rhs_firstsegment eq ""} {
if {$rhs_firstsegment eq ""} {
set rhs_entire_path [string range $str $firstc+1 end]
#assert lhs_firstsegment not empty since firstc > 0
#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
}
@ -489,7 +489,7 @@ namespace eval punk::path {
}
return $str
}
#purely string based - no reference to filesystem knowledge
#purely string based - no reference to filesystem knowledge
#unix-style forward slash only
proc plainjoin {args} {
set args [lmap a $args {string map "\\\\ /" $a}]
@ -499,12 +499,12 @@ namespace eval punk::path {
set out ""
foreach a $args {
if {![string length $out]} {
append out [plain $a]
append out [plain $a]
} else {
set a [plain $a]
if {[string map {/ ""} $out] eq ""} {
set out [string range $out 0 end-1]
}
}
if {[string map {/ ""} $a] eq ""} {
#all / segment
@ -512,16 +512,16 @@ namespace eval punk::path {
} else {
if {[string length $a] > 2 && [string match "./*" $a]} {
set a [string range $a 2 end]
}
}
if {[string index $out end] eq "/"} {
append out $a
} else {
append out / $a
append out / $a
}
}
}
}
return $out
return $out
}
proc plainjoin1 {args} {
if {[llength $args] == 1} {
@ -530,9 +530,9 @@ namespace eval punk::path {
set out [trim_final_slash [lindex $args 0]]
foreach a [lrange $args 1 end] {
set a [trim_final_slash $a]
append out / $a
append out / $a
}
return $out
return $out
}
#intention?
@ -554,13 +554,13 @@ namespace eval punk::path {
#*** !doctools
#[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] ** 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
#[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] 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 ? *
@ -572,9 +572,9 @@ namespace eval punk::path {
}
switch -- $seg {
* {lappend pats {[^/]*}}
** {lappend pats {.*}}
** {lappend pats {.*}}
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 {. [.]} $seg]
if {[regexp {[*?]} $seg]} {
@ -614,14 +614,14 @@ namespace eval punk::path {
}
}
}
# -- --- --- --- --- ---
# -- --- --- --- --- ---
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"} {
set opt_nocase 0
set explicit_nocase 0
}
# -- --- --- --- --- ---
}
# -- --- --- --- --- ---
if {$opt_nocase} {
return [regexp -nocase [pathglob_as_re $pathglob] $path]
} else {
@ -651,33 +651,33 @@ namespace eval punk::path {
-call-depth-internal -default 0 -type integer
-antiglob_paths -default {} -help\
"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
files within /usr itself)
**/_aside (exlude files where _aside is last segment)
**/_aside/* (exclude folders one below an _aside folder)
**/_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\
"Patterns to match against filename portion (last segment) of each file path
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)
proc treefilenames {args} {
#*** !doctools
#[call [fun treefilenames] [opt {option value...}] [opt {globpattern...}]]
#[para]basic (glob based) list of filenames matching each pattern in tailglobs - recursive
#[para] options:
#[para] [opt -dir] <path>
#[para] [opt -dir] <path>
#[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]no natsorting - so order is dependent on filesystem
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 opt_antiglob_paths [dict get $opts -antiglob_paths]
@ -694,7 +694,7 @@ namespace eval punk::path {
set opt_dir [dict get $opts -directory]
}
if {![file isdirectory $opt_dir]} {
return [list]
return [list]
}
} else {
#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?
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
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 {
set skip 0
foreach anti $opt_antiglob_paths {
if {[globmatchpath $anti $dir]} {
set skip 1
break
break
}
}
if {$skip} {
@ -743,8 +754,8 @@ namespace eval punk::path {
#[item]
#[para] Arguments:
# [list_begin arguments]
# [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 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
# [list_end]
#[item]
#[para] Results:
@ -753,7 +764,7 @@ namespace eval punk::path {
#[item]
#[para] Notes:
#[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
#[para] On windows, the drive-letter component (only) is not case sensitive
#[example_begin]
@ -774,7 +785,7 @@ namespace eval punk::path {
#[example_begin]
# P% punk::path::relative /usr/local/etc/ /usr/local/etc/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
#[example_end]
#[list_end]
@ -791,7 +802,7 @@ namespace eval punk::path {
#avoid normalizing if possible (file normalize *very* expensive on windows)
set do_normalize 0
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]]} {
set do_normalize 1
}
@ -857,7 +868,7 @@ namespace eval punk::path::lib {
namespace path [namespace parent]
#*** !doctools
#[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]
@ -877,17 +888,17 @@ namespace eval punk::path::lib {
namespace eval punk::path::system {
#*** !doctools
#[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 {
variable pkg punk::path
variable version
set version 999999.0a1.0
set version 999999.0a1.0
}]
return

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

@ -5974,13 +5974,40 @@ tcl::namespace::eval textblock {
[>punk . rhs]\
[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} {
#todo - use punk::args
upvar ::textblock::class::opts_table_defaults toptdefaults
set defaults [tcl::dict::create\
-rows [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]
$t destroy
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.
directives include:
%B%@id%N% ?opt val...?
options: -id <str>
spec-options: -id <str>
%B%@cmd%N% ?opt val...?
options: -name <str> -help <str>
spec-options: -name <str> -help <str>
%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)
%B%@opts%N% ?opt val...?
options: -any <bool>
spec-options: -any <bool>
%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)
%B%@argdisplay%N% ?opt val...?
options: -header <str> (text for header row of table)
-body <str> (text to replace autogenerated arg info)
spec-options: -header <str> (text for header row of table)
-body <str> (text to replace autogenerated arg info)
%B%@doc%N% ?opt val...?
options: -name <str> -url <str>
spec-options: -name <str> -url <str>
%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
for subsequent lines that represent your custom arguments.
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.
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
line that doesn't begin with @ or -
@ -369,7 +374,7 @@ tcl::namespace::eval punk::args {
that @@somearg becomes an argument named @somearg)
custom leading args, switches/options (names starting with -)
and trailing values also take options:
and trailing values also take spec-options:
-type <typename>
defaults to string. If no other restrictions
@ -397,12 +402,22 @@ tcl::namespace::eval punk::args {
-optional <boolean>
(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>
-multiple <bool> (for leaders & values defines whether
subsequent received values are stored agains the same
argument name - only applies to final leader or value)
subsequent received values are stored against the same
argument name - only applies to final leader OR final value)
(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>}
A list of allowable values for an argument.
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.
If <range> allows more than one choice the value is a list
consisting of items in the choices made available through
entries in -choices/-choicegrups.
entries in -choices/-choicegroups.
-minsize (type dependant)
-maxsize (type dependant)
-range (type dependant)
@ -1667,6 +1682,7 @@ tcl::namespace::eval punk::args {
"
@leaders -min 0 -max 0
@opts
-return -default text -choices {text dict}
-form -default 0 -help\
"Ordinal index or name of command form"
@ -1694,7 +1710,7 @@ tcl::namespace::eval punk::args {
(directives are lines beginning with
@ 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.
if -type is another directive such as @id, @doc etc the
@ -1706,8 +1722,10 @@ tcl::namespace::eval punk::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\
-types {}\
-return text\
-types {}\
-form 0\
-antiglobs {}\
-override {}\
@ -1743,7 +1761,7 @@ tcl::namespace::eval punk::args {
}
dict for {k v} $opts {
switch -- $k {
-form - -types - -antiglobs - -override {}
-return - -form - -types - -antiglobs - -override {}
default {
punk::args::parse $args withid ::punk::args::resolved_def
return
@ -1764,163 +1782,185 @@ tcl::namespace::eval punk::args {
variable id_cache_rawdef
set realid [real_id $id]
if {$realid eq ""} {
return
}
if {$realid ne ""} {
set deflist [tcl::dict::get $id_cache_rawdef $realid]
set result ""
set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]]
set deflist [tcl::dict::get $id_cache_rawdef $realid]
set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]]
set opt_form [dict get $opts -form]
if {[string is integer -strict $opt_form]} {
set formname [lindex [dict get $specdict form_names] $opt_form]
} else {
set formname $opt_form
}
set opt_override [dict get $opts -override]
#set arg_info [dict get $specdict ARG_INFO]
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 suppressed_directives [list]
set suppressed_args [list]
foreach ag $opt_antiglobs {
foreach d $directives {
if {[string match $ag $d]} {
lappend suppressed_directives $d
}
set opt_form [dict get $opts -form]
if {[string is integer -strict $opt_form]} {
set formname [lindex [dict get $specdict form_names] $opt_form]
} else {
set formname $opt_form
}
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 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 suppressed_directives [list]
set suppressed_args [list]
foreach ag $opt_antiglobs {
foreach d $directives {
if {[string match $ag $d]} {
lappend suppressed_directives $d
}
foreach argname [dict keys $arg_info] {
if {[string match $ag $argname]} {
lappend suppressed_args $argname
}
}
foreach argname [dict keys $arg_info] {
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]
foreach pat $patterns {
set matches [dict keys $arg_info $pat]
lappend globbed {*}$matches
}
set globbed [lsort -unique $globbed]
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]"
}
}
set globbed [list]
foreach pat $patterns {
set matches [dict keys $arg_info $pat]
lappend globbed {*}$matches
}
set globbed [lsort -unique $globbed]
set included_args [punk::args::system::punklib_ldiff $globbed $suppressed_args]
if {$pseudodirective in $included_directives} {
foreach m $included_args {
set argspec [dict get $arg_info $m]
if {[dict get $argspec -ARGTYPE] eq $tp} {
set argspec [dict remove $argspec -ARGTYPE]
if {[dict exists $opt_override $m]} {
append result \n "$m [dict merge $argspec [dict get $opt_override $m]]"
} else {
append result \n "$m $argspec"
}
}
}
}
set result ""
set resultdict [dict create]
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]]"
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 {
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]]"
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]]"
dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]
} 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 {
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]]"
} else {
append result \n "$type [dict get $specdict ${tp}_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}
}
}
@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]]"
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]]"
dict set resultdict $directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]
} 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 {
#pseudo-directives
if {$type in $included_directives} {
if {$pseudodirective in $included_directives} {
foreach m $included_args {
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]
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 {
}
@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]
#[copyright "2023"]
#[titledesc {Filesystem path utilities}] [comment {-- Name section and table of contents description --}]
#[moddesc {punk path filesystem utils}] [comment {-- Description at end of page heading --}]
#[moddesc {punk path filesystem utils}] [comment {-- Description at end of page heading --}]
#[require punk::path]
#[description]
#[keywords module path filesystem]
@ -104,21 +104,21 @@ namespace eval punk::path {
#*** !doctools
#[subsection {Namespace punk::path}]
#[para] Core API functions for punk::path
#[para] Core API functions for punk::path
#[list_begin definitions]
# -- ---
# -- ---
#punk::path::normjoin
# - 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
#(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
#
#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:
# <scheme>://<something>
# <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)
#
#The caller should do the file/vfs operations to determine this - not us.
# -- ---
# -- ---
#simplify path with respect to /./ & /../ elements - independent of platform
#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)
@ -148,9 +148,9 @@ namespace eval punk::path {
#known issues:
#1)
# 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.
# 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.
# won't fix?
#2)
@ -164,16 +164,16 @@ namespace eval punk::path {
# 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
# possibly won't fix - review
#4) inconsistency
#4) inconsistency
# we return normalized //server/share for //./UNC/server share
# but other dos device paths are maintained
# 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.
# caller should
# #as with 'case' below - caller will need to run a post 'file normalize'
# caller should
# #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.
# 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)
@ -194,14 +194,14 @@ namespace eval punk::path {
/// {
#if this is effectively //$emptyservername/
#then for consistency we should trail //<servername with a slash too?
#we can't transform to // or /
#we can't transform to // or /
return ///
#assert - code below should return /// (empty server prefix) for any number of leading slashes >=3
#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
#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 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
#set parts [file split [string range $path 1 end]]
set parts [split $path /]
#assert parts here has {} {} as first 2 entries
#assert parts here has {} {} as first 2 entries
set rootindex 2
#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
#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 ?
#todo - make an option for zipfs and others to determine the 'base'
#if {"zipfs:" eq [lindex $parts 2]} {
@ -281,7 +281,7 @@ namespace eval punk::path {
#set parts [file split $path]
set parts [::split $path /]
#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
if {[string match *: [lindex $parts 0]]} {
if {[lindex $parts 1] eq ""} {
@ -295,9 +295,9 @@ namespace eval punk::path {
} elseif {[lindex $parts 0] ne ""} {
#relpath a/b/c
set parts [linsert $parts 0 .]
set rootindex 0
#allow backtracking arbitrarily for leading .. entries - simplify where possible
#also need to stop possible conversion to absolute path
set rootindex 0
#allow backtracking arbitrarily for leading .. entries - simplify where possible
#also need to stop possible conversion to absolute path
set is_relpath 1
}
}
@ -306,7 +306,7 @@ namespace eval punk::path {
#puts stderr "-->baseparts:$baseparts"
#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
#
#
set finalparts [list [lindex $baseparts 0]]
foreach b [lrange $baseparts 1 end] {
if {$b ni {. ..}} {
@ -333,7 +333,7 @@ namespace eval punk::path {
lappend finalparts $p
}
}
incr i
incr i
}
} else {
foreach p [lrange $parts $rootindex+1 end] {
@ -345,7 +345,7 @@ namespace eval punk::path {
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 {
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'
# - no volumerelative
#x-platform - punk::path::pathtype - can be used in safe interps - different concept of pathtypes to 'file pathtype'
# - no volumerelative
# - 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)
# - xxx:// as absolute (scheme)
# - 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
# COM1 = COM1:
# COM1 = COM1:
# //./COM1 ?? review
proc pathtype {str} {
@ -425,7 +425,7 @@ namespace eval punk::path {
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.
set firstslash [string first / $str]
if {$firstslash == -1} {
@ -434,9 +434,9 @@ namespace eval punk::path {
set firstsegment [string range $str 0 $firstslash-1]
}
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
if {$rhs_firstsegment eq ""} {
if {$rhs_firstsegment eq ""} {
set rhs_entire_path [string range $str $firstc+1 end]
#assert lhs_firstsegment not empty since firstc > 0
#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
}
@ -489,7 +489,7 @@ namespace eval punk::path {
}
return $str
}
#purely string based - no reference to filesystem knowledge
#purely string based - no reference to filesystem knowledge
#unix-style forward slash only
proc plainjoin {args} {
set args [lmap a $args {string map "\\\\ /" $a}]
@ -499,12 +499,12 @@ namespace eval punk::path {
set out ""
foreach a $args {
if {![string length $out]} {
append out [plain $a]
append out [plain $a]
} else {
set a [plain $a]
if {[string map {/ ""} $out] eq ""} {
set out [string range $out 0 end-1]
}
}
if {[string map {/ ""} $a] eq ""} {
#all / segment
@ -512,16 +512,16 @@ namespace eval punk::path {
} else {
if {[string length $a] > 2 && [string match "./*" $a]} {
set a [string range $a 2 end]
}
}
if {[string index $out end] eq "/"} {
append out $a
} else {
append out / $a
append out / $a
}
}
}
}
return $out
return $out
}
proc plainjoin1 {args} {
if {[llength $args] == 1} {
@ -530,9 +530,9 @@ namespace eval punk::path {
set out [trim_final_slash [lindex $args 0]]
foreach a [lrange $args 1 end] {
set a [trim_final_slash $a]
append out / $a
append out / $a
}
return $out
return $out
}
#intention?
@ -554,13 +554,13 @@ namespace eval punk::path {
#*** !doctools
#[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] ** 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
#[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] 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 ? *
@ -572,9 +572,9 @@ namespace eval punk::path {
}
switch -- $seg {
* {lappend pats {[^/]*}}
** {lappend pats {.*}}
** {lappend pats {.*}}
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 {. [.]} $seg]
if {[regexp {[*?]} $seg]} {
@ -614,14 +614,14 @@ namespace eval punk::path {
}
}
}
# -- --- --- --- --- ---
# -- --- --- --- --- ---
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"} {
set opt_nocase 0
set explicit_nocase 0
}
# -- --- --- --- --- ---
}
# -- --- --- --- --- ---
if {$opt_nocase} {
return [regexp -nocase [pathglob_as_re $pathglob] $path]
} else {
@ -651,33 +651,33 @@ namespace eval punk::path {
-call-depth-internal -default 0 -type integer
-antiglob_paths -default {} -help\
"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
files within /usr itself)
**/_aside (exlude files where _aside is last segment)
**/_aside/* (exclude folders one below an _aside folder)
**/_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\
"Patterns to match against filename portion (last segment) of each file path
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)
proc treefilenames {args} {
#*** !doctools
#[call [fun treefilenames] [opt {option value...}] [opt {globpattern...}]]
#[para]basic (glob based) list of filenames matching each pattern in tailglobs - recursive
#[para] options:
#[para] [opt -dir] <path>
#[para] [opt -dir] <path>
#[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]no natsorting - so order is dependent on filesystem
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 opt_antiglob_paths [dict get $opts -antiglob_paths]
@ -694,7 +694,7 @@ namespace eval punk::path {
set opt_dir [dict get $opts -directory]
}
if {![file isdirectory $opt_dir]} {
return [list]
return [list]
}
} else {
#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?
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
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 {
set skip 0
foreach anti $opt_antiglob_paths {
if {[globmatchpath $anti $dir]} {
set skip 1
break
break
}
}
if {$skip} {
@ -743,8 +754,8 @@ namespace eval punk::path {
#[item]
#[para] Arguments:
# [list_begin arguments]
# [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 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
# [list_end]
#[item]
#[para] Results:
@ -753,7 +764,7 @@ namespace eval punk::path {
#[item]
#[para] Notes:
#[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
#[para] On windows, the drive-letter component (only) is not case sensitive
#[example_begin]
@ -774,7 +785,7 @@ namespace eval punk::path {
#[example_begin]
# P% punk::path::relative /usr/local/etc/ /usr/local/etc/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
#[example_end]
#[list_end]
@ -791,7 +802,7 @@ namespace eval punk::path {
#avoid normalizing if possible (file normalize *very* expensive on windows)
set do_normalize 0
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]]} {
set do_normalize 1
}
@ -857,7 +868,7 @@ namespace eval punk::path::lib {
namespace path [namespace parent]
#*** !doctools
#[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]
@ -877,17 +888,17 @@ namespace eval punk::path::lib {
namespace eval punk::path::system {
#*** !doctools
#[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 {
variable pkg punk::path
variable version
set version 0.1.0
set version 0.1.0
}]
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::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} {
#todo - use punk::args
upvar ::textblock::class::opts_table_defaults toptdefaults
set defaults [tcl::dict::create\
-rows [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]
$t destroy
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.
directives include:
%B%@id%N% ?opt val...?
options: -id <str>
spec-options: -id <str>
%B%@cmd%N% ?opt val...?
options: -name <str> -help <str>
spec-options: -name <str> -help <str>
%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)
%B%@opts%N% ?opt val...?
options: -any <bool>
spec-options: -any <bool>
%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)
%B%@argdisplay%N% ?opt val...?
options: -header <str> (text for header row of table)
-body <str> (text to replace autogenerated arg info)
spec-options: -header <str> (text for header row of table)
-body <str> (text to replace autogenerated arg info)
%B%@doc%N% ?opt val...?
options: -name <str> -url <str>
spec-options: -name <str> -url <str>
%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
for subsequent lines that represent your custom arguments.
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.
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
line that doesn't begin with @ or -
@ -369,7 +374,7 @@ tcl::namespace::eval punk::args {
that @@somearg becomes an argument named @somearg)
custom leading args, switches/options (names starting with -)
and trailing values also take options:
and trailing values also take spec-options:
-type <typename>
defaults to string. If no other restrictions
@ -397,12 +402,22 @@ tcl::namespace::eval punk::args {
-optional <boolean>
(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>
-multiple <bool> (for leaders & values defines whether
subsequent received values are stored agains the same
argument name - only applies to final leader or value)
subsequent received values are stored against the same
argument name - only applies to final leader OR final value)
(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>}
A list of allowable values for an argument.
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.
If <range> allows more than one choice the value is a list
consisting of items in the choices made available through
entries in -choices/-choicegrups.
entries in -choices/-choicegroups.
-minsize (type dependant)
-maxsize (type dependant)
-range (type dependant)
@ -1667,6 +1682,7 @@ tcl::namespace::eval punk::args {
"
@leaders -min 0 -max 0
@opts
-return -default text -choices {text dict}
-form -default 0 -help\
"Ordinal index or name of command form"
@ -1694,7 +1710,7 @@ tcl::namespace::eval punk::args {
(directives are lines beginning with
@ 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.
if -type is another directive such as @id, @doc etc the
@ -1706,8 +1722,10 @@ tcl::namespace::eval punk::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\
-types {}\
-return text\
-types {}\
-form 0\
-antiglobs {}\
-override {}\
@ -1743,7 +1761,7 @@ tcl::namespace::eval punk::args {
}
dict for {k v} $opts {
switch -- $k {
-form - -types - -antiglobs - -override {}
-return - -form - -types - -antiglobs - -override {}
default {
punk::args::parse $args withid ::punk::args::resolved_def
return
@ -1764,163 +1782,185 @@ tcl::namespace::eval punk::args {
variable id_cache_rawdef
set realid [real_id $id]
if {$realid eq ""} {
return
}
if {$realid ne ""} {
set deflist [tcl::dict::get $id_cache_rawdef $realid]
set result ""
set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]]
set deflist [tcl::dict::get $id_cache_rawdef $realid]
set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]]
set opt_form [dict get $opts -form]
if {[string is integer -strict $opt_form]} {
set formname [lindex [dict get $specdict form_names] $opt_form]
} else {
set formname $opt_form
}
set opt_override [dict get $opts -override]
#set arg_info [dict get $specdict ARG_INFO]
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 suppressed_directives [list]
set suppressed_args [list]
foreach ag $opt_antiglobs {
foreach d $directives {
if {[string match $ag $d]} {
lappend suppressed_directives $d
}
set opt_form [dict get $opts -form]
if {[string is integer -strict $opt_form]} {
set formname [lindex [dict get $specdict form_names] $opt_form]
} else {
set formname $opt_form
}
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 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 suppressed_directives [list]
set suppressed_args [list]
foreach ag $opt_antiglobs {
foreach d $directives {
if {[string match $ag $d]} {
lappend suppressed_directives $d
}
foreach argname [dict keys $arg_info] {
if {[string match $ag $argname]} {
lappend suppressed_args $argname
}
}
foreach argname [dict keys $arg_info] {
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]
foreach pat $patterns {
set matches [dict keys $arg_info $pat]
lappend globbed {*}$matches
}
set globbed [lsort -unique $globbed]
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]"
}
}
set globbed [list]
foreach pat $patterns {
set matches [dict keys $arg_info $pat]
lappend globbed {*}$matches
}
set globbed [lsort -unique $globbed]
set included_args [punk::args::system::punklib_ldiff $globbed $suppressed_args]
if {$pseudodirective in $included_directives} {
foreach m $included_args {
set argspec [dict get $arg_info $m]
if {[dict get $argspec -ARGTYPE] eq $tp} {
set argspec [dict remove $argspec -ARGTYPE]
if {[dict exists $opt_override $m]} {
append result \n "$m [dict merge $argspec [dict get $opt_override $m]]"
} else {
append result \n "$m $argspec"
}
}
}
}
set result ""
set resultdict [dict create]
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]]"
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 {
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]]"
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]]"
dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]
} 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 {
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]]"
} else {
append result \n "$type [dict get $specdict ${tp}_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}
}
}
@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]]"
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]]"
dict set resultdict $directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]
} 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 {
#pseudo-directives
if {$type in $included_directives} {
if {$pseudodirective in $included_directives} {
foreach m $included_args {
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]
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 {
}
@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]
#[copyright "2023"]
#[titledesc {Filesystem path utilities}] [comment {-- Name section and table of contents description --}]
#[moddesc {punk path filesystem utils}] [comment {-- Description at end of page heading --}]
#[moddesc {punk path filesystem utils}] [comment {-- Description at end of page heading --}]
#[require punk::path]
#[description]
#[keywords module path filesystem]
@ -104,21 +104,21 @@ namespace eval punk::path {
#*** !doctools
#[subsection {Namespace punk::path}]
#[para] Core API functions for punk::path
#[para] Core API functions for punk::path
#[list_begin definitions]
# -- ---
# -- ---
#punk::path::normjoin
# - 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
#(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
#
#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:
# <scheme>://<something>
# <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)
#
#The caller should do the file/vfs operations to determine this - not us.
# -- ---
# -- ---
#simplify path with respect to /./ & /../ elements - independent of platform
#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)
@ -148,9 +148,9 @@ namespace eval punk::path {
#known issues:
#1)
# 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.
# 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.
# won't fix?
#2)
@ -164,16 +164,16 @@ namespace eval punk::path {
# 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
# possibly won't fix - review
#4) inconsistency
#4) inconsistency
# we return normalized //server/share for //./UNC/server share
# but other dos device paths are maintained
# 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.
# caller should
# #as with 'case' below - caller will need to run a post 'file normalize'
# caller should
# #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.
# 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)
@ -194,14 +194,14 @@ namespace eval punk::path {
/// {
#if this is effectively //$emptyservername/
#then for consistency we should trail //<servername with a slash too?
#we can't transform to // or /
#we can't transform to // or /
return ///
#assert - code below should return /// (empty server prefix) for any number of leading slashes >=3
#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
#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 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
#set parts [file split [string range $path 1 end]]
set parts [split $path /]
#assert parts here has {} {} as first 2 entries
#assert parts here has {} {} as first 2 entries
set rootindex 2
#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
#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 ?
#todo - make an option for zipfs and others to determine the 'base'
#if {"zipfs:" eq [lindex $parts 2]} {
@ -281,7 +281,7 @@ namespace eval punk::path {
#set parts [file split $path]
set parts [::split $path /]
#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
if {[string match *: [lindex $parts 0]]} {
if {[lindex $parts 1] eq ""} {
@ -295,9 +295,9 @@ namespace eval punk::path {
} elseif {[lindex $parts 0] ne ""} {
#relpath a/b/c
set parts [linsert $parts 0 .]
set rootindex 0
#allow backtracking arbitrarily for leading .. entries - simplify where possible
#also need to stop possible conversion to absolute path
set rootindex 0
#allow backtracking arbitrarily for leading .. entries - simplify where possible
#also need to stop possible conversion to absolute path
set is_relpath 1
}
}
@ -306,7 +306,7 @@ namespace eval punk::path {
#puts stderr "-->baseparts:$baseparts"
#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
#
#
set finalparts [list [lindex $baseparts 0]]
foreach b [lrange $baseparts 1 end] {
if {$b ni {. ..}} {
@ -333,7 +333,7 @@ namespace eval punk::path {
lappend finalparts $p
}
}
incr i
incr i
}
} else {
foreach p [lrange $parts $rootindex+1 end] {
@ -345,7 +345,7 @@ namespace eval punk::path {
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 {
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'
# - no volumerelative
#x-platform - punk::path::pathtype - can be used in safe interps - different concept of pathtypes to 'file pathtype'
# - no volumerelative
# - 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)
# - xxx:// as absolute (scheme)
# - 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
# COM1 = COM1:
# COM1 = COM1:
# //./COM1 ?? review
proc pathtype {str} {
@ -425,7 +425,7 @@ namespace eval punk::path {
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.
set firstslash [string first / $str]
if {$firstslash == -1} {
@ -434,9 +434,9 @@ namespace eval punk::path {
set firstsegment [string range $str 0 $firstslash-1]
}
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
if {$rhs_firstsegment eq ""} {
if {$rhs_firstsegment eq ""} {
set rhs_entire_path [string range $str $firstc+1 end]
#assert lhs_firstsegment not empty since firstc > 0
#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
}
@ -489,7 +489,7 @@ namespace eval punk::path {
}
return $str
}
#purely string based - no reference to filesystem knowledge
#purely string based - no reference to filesystem knowledge
#unix-style forward slash only
proc plainjoin {args} {
set args [lmap a $args {string map "\\\\ /" $a}]
@ -499,12 +499,12 @@ namespace eval punk::path {
set out ""
foreach a $args {
if {![string length $out]} {
append out [plain $a]
append out [plain $a]
} else {
set a [plain $a]
if {[string map {/ ""} $out] eq ""} {
set out [string range $out 0 end-1]
}
}
if {[string map {/ ""} $a] eq ""} {
#all / segment
@ -512,16 +512,16 @@ namespace eval punk::path {
} else {
if {[string length $a] > 2 && [string match "./*" $a]} {
set a [string range $a 2 end]
}
}
if {[string index $out end] eq "/"} {
append out $a
} else {
append out / $a
append out / $a
}
}
}
}
return $out
return $out
}
proc plainjoin1 {args} {
if {[llength $args] == 1} {
@ -530,9 +530,9 @@ namespace eval punk::path {
set out [trim_final_slash [lindex $args 0]]
foreach a [lrange $args 1 end] {
set a [trim_final_slash $a]
append out / $a
append out / $a
}
return $out
return $out
}
#intention?
@ -554,13 +554,13 @@ namespace eval punk::path {
#*** !doctools
#[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] ** 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
#[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] 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 ? *
@ -572,9 +572,9 @@ namespace eval punk::path {
}
switch -- $seg {
* {lappend pats {[^/]*}}
** {lappend pats {.*}}
** {lappend pats {.*}}
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 {. [.]} $seg]
if {[regexp {[*?]} $seg]} {
@ -614,14 +614,14 @@ namespace eval punk::path {
}
}
}
# -- --- --- --- --- ---
# -- --- --- --- --- ---
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"} {
set opt_nocase 0
set explicit_nocase 0
}
# -- --- --- --- --- ---
}
# -- --- --- --- --- ---
if {$opt_nocase} {
return [regexp -nocase [pathglob_as_re $pathglob] $path]
} else {
@ -651,33 +651,33 @@ namespace eval punk::path {
-call-depth-internal -default 0 -type integer
-antiglob_paths -default {} -help\
"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
files within /usr itself)
**/_aside (exlude files where _aside is last segment)
**/_aside/* (exclude folders one below an _aside folder)
**/_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\
"Patterns to match against filename portion (last segment) of each file path
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)
proc treefilenames {args} {
#*** !doctools
#[call [fun treefilenames] [opt {option value...}] [opt {globpattern...}]]
#[para]basic (glob based) list of filenames matching each pattern in tailglobs - recursive
#[para] options:
#[para] [opt -dir] <path>
#[para] [opt -dir] <path>
#[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]no natsorting - so order is dependent on filesystem
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 opt_antiglob_paths [dict get $opts -antiglob_paths]
@ -694,7 +694,7 @@ namespace eval punk::path {
set opt_dir [dict get $opts -directory]
}
if {![file isdirectory $opt_dir]} {
return [list]
return [list]
}
} else {
#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?
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
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 {
set skip 0
foreach anti $opt_antiglob_paths {
if {[globmatchpath $anti $dir]} {
set skip 1
break
break
}
}
if {$skip} {
@ -743,8 +754,8 @@ namespace eval punk::path {
#[item]
#[para] Arguments:
# [list_begin arguments]
# [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 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
# [list_end]
#[item]
#[para] Results:
@ -753,7 +764,7 @@ namespace eval punk::path {
#[item]
#[para] Notes:
#[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
#[para] On windows, the drive-letter component (only) is not case sensitive
#[example_begin]
@ -774,7 +785,7 @@ namespace eval punk::path {
#[example_begin]
# P% punk::path::relative /usr/local/etc/ /usr/local/etc/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
#[example_end]
#[list_end]
@ -791,7 +802,7 @@ namespace eval punk::path {
#avoid normalizing if possible (file normalize *very* expensive on windows)
set do_normalize 0
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]]} {
set do_normalize 1
}
@ -857,7 +868,7 @@ namespace eval punk::path::lib {
namespace path [namespace parent]
#*** !doctools
#[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]
@ -877,17 +888,17 @@ namespace eval punk::path::lib {
namespace eval punk::path::system {
#*** !doctools
#[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 {
variable pkg punk::path
variable version
set version 0.1.0
set version 0.1.0
}]
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::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} {
#todo - use punk::args
upvar ::textblock::class::opts_table_defaults toptdefaults
set defaults [tcl::dict::create\
-rows [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]
$t destroy
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