2147 changed files with 842643 additions and 8297 deletions
@ -0,0 +1,568 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) Julian Noble 2024 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application argparsingtest 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license MIT |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin punkshell_module_argparsingtest 0 0.1.0] |
||||
#[copyright "2024"] |
||||
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||
#[require argparsingtest] |
||||
#[keywords module] |
||||
#[description] |
||||
#[para] - |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of argparsingtest |
||||
#[subsection Concepts] |
||||
#[para] - |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by argparsingtest |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6- |
||||
package require punk::args |
||||
package require struct::set |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6}] |
||||
#[item] [package {punk::args}] |
||||
|
||||
# #package require frobz |
||||
# #*** !doctools |
||||
# #[item] [package {frobz}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# oo::class namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval argparsingtest::class { |
||||
#*** !doctools |
||||
#[subsection {Namespace argparsingtest::class}] |
||||
#[para] class definitions |
||||
if {[info commands [namespace current]::interface_sample1] eq ""} { |
||||
#*** !doctools |
||||
#[list_begin enumerated] |
||||
|
||||
# oo::class create interface_sample1 { |
||||
# #*** !doctools |
||||
# #[enum] CLASS [class interface_sample1] |
||||
# #[list_begin definitions] |
||||
|
||||
# method test {arg1} { |
||||
# #*** !doctools |
||||
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||
# #[para] test method |
||||
# puts "test: $arg1" |
||||
# } |
||||
|
||||
# #*** !doctools |
||||
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||
# } |
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end class enumeration ---}] |
||||
} |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Base namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval argparsingtest { |
||||
namespace export {[a-z]*} ;# Convention: export all lowercase |
||||
#variable xyz |
||||
|
||||
#*** !doctools |
||||
#[subsection {Namespace argparsingtest}] |
||||
#[para] Core API functions for argparsingtest |
||||
#[list_begin definitions] |
||||
|
||||
proc test1_ni {args} { |
||||
set defaults [dict create\ |
||||
-return string\ |
||||
-frametype \uFFEF\ |
||||
-show_edge \uFFEF\ |
||||
-show_seps \uFFEF\ |
||||
-x ""\ |
||||
-y b\ |
||||
-z c\ |
||||
-1 1\ |
||||
-2 2\ |
||||
-3 3\ |
||||
] |
||||
foreach {k v} $args { |
||||
if {$k ni [dict keys $defaults]} { |
||||
error "unrecognised option '$k'. Known options [dict keys $defaults]" |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $args] |
||||
} |
||||
proc test1_switchmerge {args} { |
||||
set defaults [dict create\ |
||||
-return string\ |
||||
-frametype \uFFEF\ |
||||
-show_edge \uFFEF\ |
||||
-show_seps \uFFEF\ |
||||
-x ""\ |
||||
-y b\ |
||||
-z c\ |
||||
-1 1\ |
||||
-2 2\ |
||||
-3 3\ |
||||
] |
||||
foreach {k v} $args { |
||||
switch -- $k { |
||||
-return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 {} |
||||
default { |
||||
error "unrecognised option '$k'. Known options [dict keys $defaults]" |
||||
} |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $args] |
||||
} |
||||
#if we need to loop to test arg validity anyway - then dict set as we go is slightly faster than a dict merge at the end |
||||
proc test1_switch {args} { |
||||
set opts [dict create\ |
||||
-return string\ |
||||
-frametype \uFFEF\ |
||||
-show_edge \uFFEF\ |
||||
-show_seps \uFFEF\ |
||||
-x ""\ |
||||
-y b\ |
||||
-z c\ |
||||
-1 1\ |
||||
-2 2\ |
||||
-3 3\ |
||||
] |
||||
foreach {k v} $args { |
||||
switch -- $k { |
||||
-return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { |
||||
dict set opts $k $v |
||||
} |
||||
default { |
||||
error "unrecognised option '$k'. Known options [dict keys $opts]" |
||||
} |
||||
} |
||||
} |
||||
return $opts |
||||
} |
||||
variable switchopts |
||||
set switchopts [dict create\ |
||||
-return string\ |
||||
-frametype \uFFEF\ |
||||
-show_edge \uFFEF\ |
||||
-show_seps \uFFEF\ |
||||
-x ""\ |
||||
-y b\ |
||||
-z c\ |
||||
-1 1\ |
||||
-2 2\ |
||||
-3 3\ |
||||
] |
||||
#slightly slower than just creating the dict within the proc |
||||
proc test1_switch_nsvar {args} { |
||||
variable switchopts |
||||
set opts $switchopts |
||||
foreach {k v} $args { |
||||
switch -- $k { |
||||
-return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { |
||||
dict set opts $k $v |
||||
} |
||||
default { |
||||
error "unrecognised option '$k'. Known options [dict keys $opts]" |
||||
} |
||||
} |
||||
} |
||||
return $opts |
||||
} |
||||
proc test1_switch2 {args} { |
||||
set opts [dict create\ |
||||
-return string\ |
||||
-frametype \uFFEF\ |
||||
-show_edge \uFFEF\ |
||||
-show_seps \uFFEF\ |
||||
-x ""\ |
||||
-y b\ |
||||
-z c\ |
||||
-1 1\ |
||||
-2 2\ |
||||
-3 3\ |
||||
] |
||||
set switches [lmap v [dict keys $opts] {list $v -}] |
||||
set switches [concat {*}$switches] |
||||
set switches [lrange $switches 0 end-1] |
||||
foreach {k v} $args { |
||||
switch -- $k\ |
||||
{*}$switches { |
||||
dict set opts $k $v |
||||
}\ |
||||
default { |
||||
error "unrecognised option '$k'. Known options [dict keys $opts]" |
||||
} |
||||
} |
||||
return $opts |
||||
} |
||||
proc test1_prefix {args} { |
||||
set opts [dict create\ |
||||
-return string\ |
||||
-frametype \uFFEF\ |
||||
-show_edge \uFFEF\ |
||||
-show_seps \uFFEF\ |
||||
-x ""\ |
||||
-y b\ |
||||
-z c\ |
||||
-1 1\ |
||||
-2 2\ |
||||
-3 3\ |
||||
] |
||||
foreach {k v} $args { |
||||
dict set opts [tcl::prefix::match -message "test1_prefix option $k" {-return -frametype -show_edge -show_seps -x -y -z -1 -2 -3} $k] $v |
||||
} |
||||
return $opts |
||||
} |
||||
proc test1_prefix2 {args} { |
||||
set opts [dict create\ |
||||
-return string\ |
||||
-frametype \uFFEF\ |
||||
-show_edge \uFFEF\ |
||||
-show_seps \uFFEF\ |
||||
-x ""\ |
||||
-y b\ |
||||
-z c\ |
||||
-1 1\ |
||||
-2 2\ |
||||
-3 3\ |
||||
] |
||||
if {[llength $args]} { |
||||
set knownflags [dict keys $opts] |
||||
} |
||||
foreach {k v} $args { |
||||
dict set opts [tcl::prefix::match -message "test1_prefix2 option $k" $knownflags $k] $v |
||||
} |
||||
return $opts |
||||
} |
||||
|
||||
#punk::args is slower than argp - but comparable, and argp doesn't support solo flags |
||||
proc test1_punkargs {args} { |
||||
set argd [punk::args::parse $args withdef { |
||||
@id -id ::argparsingtest::test1_punkargs |
||||
@cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" |
||||
@opts -anyopts 0 |
||||
-return -default string -type string |
||||
-frametype -default \uFFEF -type string |
||||
-show_edge -default \uFFEF -type string |
||||
-show_seps -default \uFFEF -type string |
||||
-join -type none -multiple 1 |
||||
-x -default "" -type string |
||||
-y -default b -type string |
||||
-z -default c -type string |
||||
-1 -default 1 -type boolean |
||||
-2 -default 2 -type integer |
||||
-3 -default 3 -type integer |
||||
@values |
||||
}] |
||||
return [tcl::dict::get $argd opts] |
||||
} |
||||
|
||||
punk::args::define { |
||||
@id -id ::test1_punkargs_by_id |
||||
@cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" |
||||
@opts -anyopts 0 |
||||
-return -default string -type string |
||||
-frametype -default \uFFEF -type string |
||||
-show_edge -default \uFFEF -type string |
||||
-show_seps -default \uFFEF -type string |
||||
-join -type none -multiple 1 |
||||
-x -default "" -type string |
||||
-y -default b -type string |
||||
-z -default c -type string |
||||
-1 -default 1 -type boolean |
||||
-2 -default 2 -type integer |
||||
-3 -default 3 -type integer |
||||
@values |
||||
} |
||||
proc test1_punkargs_by_id {args} { |
||||
set argd [punk::args::get_by_id ::test1_punkargs_by_id $args] |
||||
return [tcl::dict::get $argd opts] |
||||
} |
||||
|
||||
punk::args::define { |
||||
@id -id ::argparsingtest::test1_punkargs2 |
||||
@cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" |
||||
@opts -anyopts 0 |
||||
-return -default string -type string |
||||
-frametype -default \uFFEF -type string |
||||
-show_edge -default \uFFEF -type string |
||||
-show_seps -default \uFFEF -type string |
||||
-join -type none -multiple 1 |
||||
-x -default "" -type string |
||||
-y -default b -type string |
||||
-z -default c -type string |
||||
-1 -default 1 -type boolean |
||||
-2 -default 2 -type integer |
||||
-3 -default 3 -type integer |
||||
@values |
||||
} |
||||
proc test1_punkargs2 {args} { |
||||
set argd [punk::args::get_by_id ::argparsingtest::test1_punkargs2 $args] |
||||
return [tcl::dict::get $argd opts] |
||||
} |
||||
|
||||
|
||||
proc test1_punkargs_validate_ansistripped {args} { |
||||
set argd [punk::args::get_dict { |
||||
@id -id ::argparsingtest::test1_punkargs_validate_ansistripped |
||||
@cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" |
||||
@opts -anyopts 0 |
||||
-return -default string -type string -choices {string object} -help "return type" |
||||
-frametype -default \uFFEF -type string |
||||
-show_edge -default \uFFEF -type string |
||||
-show_seps -default \uFFEF -type string |
||||
-join -type none -multiple 1 |
||||
-x -default "" -type string |
||||
-y -default b -type string |
||||
-z -default c -type string |
||||
-1 -default 1 -type boolean -validate_ansistripped true |
||||
-2 -default 2 -type integer -validate_ansistripped true |
||||
-3 -default 3 -type integer -validate_ansistripped true |
||||
@values |
||||
} $args] |
||||
return [tcl::dict::get $argd opts] |
||||
} |
||||
|
||||
package require opt |
||||
variable optlist |
||||
tcl::OptProc test1_opt { |
||||
{-return string "return type"} |
||||
{-frametype \uFFEF "type of frame"} |
||||
{-show_edge \uFFEF "show table outer borders"} |
||||
{-show_seps \uFFEF "show separators"} |
||||
{-join "solo option"} |
||||
{-x "" "x val"} |
||||
{-y b "y val"} |
||||
{-z c "z val"} |
||||
{-1 1 "1val"} |
||||
{-2 -int 2 "2val"} |
||||
{-3 -int 3 "3val"} |
||||
} { |
||||
set opts [dict create] |
||||
foreach v [info locals] { |
||||
dict set opts $v [set $v] |
||||
} |
||||
return $opts |
||||
} |
||||
|
||||
package require cmdline |
||||
#cmdline::getoptions is much faster than typedGetoptions |
||||
proc test1_cmdline_untyped {args} { |
||||
set cmdlineopts_untyped { |
||||
{return.arg "string" "return val"} |
||||
{frametype.arg \uFFEF "frame type"} |
||||
{show_edge.arg \uFFEF "show table borders"} |
||||
{show_seps.arg \uFFEF "show table seps"} |
||||
{join "join the things"} |
||||
{x.arg "" "arg x"} |
||||
{y.arg b "arg y"} |
||||
{z.arg c "arg z"} |
||||
{1.arg 1 "arg 1"} |
||||
{2.arg 2 "arg 2"} |
||||
{3.arg 3 "arg 3"} |
||||
} |
||||
|
||||
set usage "usage etc" |
||||
return [::cmdline::getoptions args $cmdlineopts_untyped $usage] |
||||
} |
||||
proc test1_cmdline_typed {args} { |
||||
set cmdlineopts_typed { |
||||
{return.arg "string" "return val"} |
||||
{frametype.arg \uFFEF "frame type"} |
||||
{show_edge.arg \uFFEF "show table borders"} |
||||
{show_seps.arg \uFFEF "show table seps"} |
||||
{join "join the things"} |
||||
{x.arg "" "arg x"} |
||||
{y.arg b "arg y"} |
||||
{z.arg c "arg z"} |
||||
{1.boolean 1 "arg 1"} |
||||
{2.integer 2 "arg 2"} |
||||
{3.integer 3 "arg 3"} |
||||
} |
||||
|
||||
set usage "usage etc" |
||||
return [::cmdline::typedGetoptions args $cmdlineopts_typed $usage] |
||||
} |
||||
|
||||
catch { |
||||
package require argp |
||||
argp::registerArgs test1_argp { |
||||
{ -return string "string" } |
||||
{ -frametype string \uFFEF } |
||||
{ -show_edge string \uFFEF } |
||||
{ -show_seps string \uFFEF } |
||||
{ -x string "" } |
||||
{ -y string b } |
||||
{ -z string c } |
||||
{ -1 boolean 1 } |
||||
{ -2 integer 2 } |
||||
{ -3 integer 3 } |
||||
} |
||||
} |
||||
proc test1_argp {args} { |
||||
argp::parseArgs opts |
||||
return [array get opts] |
||||
} |
||||
|
||||
package require tepam |
||||
tepam::procedure {test1_tepam} { |
||||
-args { |
||||
{-return -type string -default string} |
||||
{-frametype -type string -default \uFFEF} |
||||
{-show_edge -type string -default \uFFEF} |
||||
{-show_seps -type string -default \uFFEF} |
||||
{-join -type none -multiple} |
||||
{-x -type string -default ""} |
||||
{-y -type string -default b} |
||||
{-z -type string -default c} |
||||
{-1 -type boolean -default 1} |
||||
{-2 -type integer -default 2} |
||||
{-3 -type integer -default 3} |
||||
} |
||||
} { |
||||
return [dict create return $return frametype $frametype show_edge $show_edge show_seps $show_seps x $x y $y z $z 1 $1 2 $2 3 $3 join $join] |
||||
} |
||||
|
||||
#multiline values use first line of each record to determine amount of indent to trim |
||||
proc test_multiline {args} { |
||||
set t3 [textblock::frame t3] |
||||
set argd [punk::args::get_dict [subst { |
||||
-template1 -default { |
||||
****** |
||||
* t1 * |
||||
****** |
||||
} |
||||
-template2 -default { ------ |
||||
****** |
||||
* t2 * |
||||
******} |
||||
-template3 -default {$t3} |
||||
#substituted or literal values with newlines - no autoindent applied - caller will have to pad appropriately |
||||
-template3b -default { |
||||
$t3 |
||||
----------------- |
||||
$t3 |
||||
abc\ndef |
||||
} |
||||
-template4 -default "****** |
||||
* t4 * |
||||
******" |
||||
-template5 -default " |
||||
|
||||
|
||||
" |
||||
-flag -default 0 -type boolean |
||||
}] $args] |
||||
return $argd |
||||
} |
||||
|
||||
#proc sample1 {p1 n args} { |
||||
# #*** !doctools |
||||
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] |
||||
# #[para]Description of sample1 |
||||
# #[para] Arguments: |
||||
# # [list_begin arguments] |
||||
# # [arg_def tring p1] A description of string argument p1. |
||||
# # [arg_def integer n] A description of integer argument n. |
||||
# # [list_end] |
||||
# return "ok" |
||||
#} |
||||
|
||||
|
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace argparsingtest ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval argparsingtest::lib { |
||||
namespace export {[a-z]*} ;# Convention: export all lowercase |
||||
namespace path [namespace parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace argparsingtest::lib}] |
||||
#[para] Secondary functions that are part of the API |
||||
#[list_begin definitions] |
||||
|
||||
#proc utility1 {p1 args} { |
||||
# #*** !doctools |
||||
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||
# #[para]Description of utility1 |
||||
# return 1 |
||||
#} |
||||
|
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace argparsingtest::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section Internal] |
||||
namespace eval argparsingtest::system { |
||||
#*** !doctools |
||||
#[subsection {Namespace argparsingtest::system}] |
||||
#[para] Internal functions that are not part of the API |
||||
|
||||
|
||||
|
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide argparsingtest [namespace eval argparsingtest { |
||||
variable pkg argparsingtest |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,853 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2025 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::pipe 1.0 |
||||
# Meta platform tcl |
||||
# Meta license MIT |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin shellspy_module_punk::pipe 0 1.0] |
||||
#[copyright "2025"] |
||||
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||
#[require punk::pipe] |
||||
#[keywords module] |
||||
#[description] |
||||
#[para] - |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of punk::pipe |
||||
#[subsection Concepts] |
||||
#[para] - |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by punk::pipe |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6- |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6}] |
||||
|
||||
# #package require frobz |
||||
# #*** !doctools |
||||
# #[item] [package {frobz}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# oo::class namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#tcl::namespace::eval punk::pipe::class { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::pipe::class}] |
||||
#[para] class definitions |
||||
#if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { |
||||
#*** !doctools |
||||
#[list_begin enumerated] |
||||
|
||||
# oo::class create interface_sample1 { |
||||
# #*** !doctools |
||||
# #[enum] CLASS [class interface_sample1] |
||||
# #[list_begin definitions] |
||||
|
||||
# method test {arg1} { |
||||
# #*** !doctools |
||||
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||
# #[para] test method |
||||
# puts "test: $arg1" |
||||
# } |
||||
|
||||
# #*** !doctools |
||||
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||
# } |
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end class enumeration ---}] |
||||
#} |
||||
#} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
tcl::namespace::eval punk::pipe { |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Base namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::pipe}] |
||||
#[para] Core API functions for punk::pipe |
||||
#[list_begin definitions] |
||||
|
||||
|
||||
|
||||
#proc sample1 {p1 n args} { |
||||
# #*** !doctools |
||||
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] |
||||
# #[para]Description of sample1 |
||||
# #[para] Arguments: |
||||
# # [list_begin arguments] |
||||
# # [arg_def tring p1] A description of string argument p1. |
||||
# # [arg_def integer n] A description of integer argument n. |
||||
# # [list_end] |
||||
# return "ok" |
||||
#} |
||||
|
||||
#https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/ |
||||
# |
||||
#we can't provide a float comparison suitable for every situation, |
||||
#but we should pick something reasonable, keep it stable, and document it. |
||||
proc float_almost_equal {a b} { |
||||
package require math::constants |
||||
set diff [expr {abs($a - $b)}] |
||||
if {$diff <= $::math::constants::eps} { |
||||
return 1 |
||||
} |
||||
set A [expr {abs($a)}] |
||||
set B [expr {abs($b)}] |
||||
set largest [expr {($B > $A) ? $B : $A}] |
||||
return [expr {$diff <= $largest * $::math::constants::eps}] |
||||
} |
||||
|
||||
#debatable whether boolean_almost_equal is more surprising than helpful. |
||||
#values from a calculation that are extremely close to zero but aren't false could also be surprising - especially if they compare equal numerically |
||||
#perhaps a fuzzy-boolean is a step too far for a default - but it's inline with float-comparison for pattern-matching. |
||||
#alternatively - use an even more complex classifier? (^&~) ? |
||||
proc boolean_almost_equal {a b} { |
||||
if {[string is double -strict $a]} { |
||||
if {[float_almost_equal $a 0]} { |
||||
set a 0 |
||||
} |
||||
} |
||||
if {[string is double -strict $b]} { |
||||
if {[float_almost_equal $b 0]} { |
||||
set b 0 |
||||
} |
||||
} |
||||
#must handle true,no etc. |
||||
expr {($a && 1) == ($b && 1)} |
||||
} |
||||
|
||||
#boolean could be tr, true, y, ye, yes,Yes, 1 , 0 etc. |
||||
proc boolean_equal {a b} { |
||||
#equivalenttly xnor: expr {!(($a && 1) ^ ($b && 1))} ;# less clear and no discernable timing benefit. |
||||
expr {($a && 1) == ($b && 1)} |
||||
} |
||||
|
||||
|
||||
proc val [list [list v [lreplace x 0 0]]] {return $v} |
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::pipe ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::pipe::lib { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
tcl::namespace::path [tcl::namespace::parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::pipe::lib}] |
||||
#[para] Secondary functions that are part of the API |
||||
#[list_begin definitions] |
||||
|
||||
#proc utility1 {p1 args} { |
||||
# #*** !doctools |
||||
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||
# #[para]Description of utility1 |
||||
# return 1 |
||||
#} |
||||
|
||||
#map rhs to names suitable to use in pipemcd proc name (whitespace mapping) |
||||
# (for .= and = pipecmds) |
||||
proc pipecmd_namemapping {rhs} { |
||||
#used to build a command from a pattern which could contain :: - we need to map it to keep it a single command in the desired namespace. |
||||
#glob chars will prevent us using simple test {[info commands $cmd] eq ""} to test existence |
||||
#we could use the test {$cmd in [info commands]} - but mapping away globchars is more robust, allowing the simpler test |
||||
#set rhs [string trim $rhs];#ignore all leading & trailing whitespace |
||||
set rhs [string trimleft $rhs] |
||||
#--- |
||||
#REVIEW! |
||||
#set rhs [regsub -all {\s{1,}} $rhs {<sp>}] ;#collapse all internal whitespace to a single <sp> token |
||||
#This stops us matching {/@**@x x} vs {/@**@x x} |
||||
#--- |
||||
|
||||
set rhs [tcl::string::map {: <c> ? <q> * <star> [ <lb> ] <rb> \\ <bsl> {"} <dq> " " <sp>} $rhs] |
||||
#review - we don't expect other command-incompatible chars such as colon? |
||||
return $rhs |
||||
} |
||||
|
||||
# relatively slow on even small sized scripts |
||||
#proc arg_is_script_shaped2 {arg} { |
||||
# set re {^(\s|;|\n)$} |
||||
# set chars [split $arg ""] |
||||
# if {[lsearch -regex $chars $re] >=0} { |
||||
# return 1 |
||||
# } else { |
||||
# return 0 |
||||
# } |
||||
#} |
||||
|
||||
#exclude quoted whitespace |
||||
proc arg_is_script_shaped {arg} { |
||||
if {[tcl::string::first \n $arg] >= 0} { |
||||
return 1 |
||||
} elseif {[tcl::string::first ";" $arg] >= 0} { |
||||
return 1 |
||||
} elseif {[tcl::string::first " " $arg] >= 0 || [tcl::string::first \t $arg] >= 0} { |
||||
lassign [_rhs_tail_split $arg] _ part2 ;#will have part2 if unquoted whitespace found |
||||
return [expr {$part2 ne ""}] |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
|
||||
#split top level of patterns only. |
||||
proc _split_patterns_memoized {varspecs} { |
||||
set name_mapped [pipecmd_namemapping $varspecs] |
||||
set cmdname ::punk::pipecmds::split_patterns::_$name_mapped |
||||
if {[info commands $cmdname] ne ""} { |
||||
return [$cmdname] |
||||
} |
||||
set result [_split_patterns $varspecs] |
||||
proc $cmdname {} [list return $result] |
||||
#debug.punk.pipe.compile {proc $cmdname} 4 |
||||
return $result |
||||
} |
||||
|
||||
|
||||
#note - empty data after trailing , is ignored. (comma as very last character) |
||||
# - fix by documentation only. double up trailing comma e.g <pattern>,, if desired to return pattern match plus all at end! |
||||
#todo - move to punk::pipe |
||||
proc _split_patterns {varspecs} { |
||||
|
||||
set varlist [list] |
||||
# @ @@ - list and dict functions |
||||
# / level separator |
||||
# # list count, ## dict size |
||||
# % string functions |
||||
# ! not |
||||
set var_terminals [list "@" "/" "#" "%" "!" ">" "<"] ;# (> required for insertionspecs at rhs of = & .= ) |
||||
#right bracket ) also ends a var - but is different depending on whether var is array or basic. For array - it forms part of the varname |
||||
|
||||
#except when prefixed directly by pin classifier ^ |
||||
set protect_terminals [list "^"] ;# e.g sequence ^# |
||||
#also - an atom usually doesn't need the / as a terminal - because it can't match a missing element unless it's empty string |
||||
#ie the one usecase is '/n to match either empty string or missing item at position n. For this one usecase - we miss the capability to atom match paths/urls .. '/usr/local/et' |
||||
set in_brackets 0 ;#count depth |
||||
set in_atom 0 |
||||
set token "" |
||||
set end_var_posn -1 ;#first var_terminal encountered within each comma delimited section |
||||
set token_index 0 ;#index of terminal char within each token |
||||
set indq 0 |
||||
set inbraces 0 |
||||
set inesc 0 ;#whether last char was backslash (see also punk::escv) |
||||
set prevc "" |
||||
set char_index 0 |
||||
#if {[string index $varspecs end] eq ","} { |
||||
# set varspecs [string range $varspecs 0 end-1] |
||||
#} |
||||
set charcount 0 |
||||
foreach c [split $varspecs ""] { |
||||
incr charcount |
||||
if {$indq} { |
||||
if {$inesc} { |
||||
#puts stderr "inesc adding '$c'" |
||||
append token \\$c |
||||
} else { |
||||
if {$c eq {"}} { |
||||
set indq 0 |
||||
} else { |
||||
append token $c |
||||
} |
||||
} |
||||
} elseif {$inbraces} { |
||||
if {$inesc} { |
||||
append token \\$c |
||||
} else { |
||||
if {$c eq "\}"} { |
||||
incr inbraces -1 |
||||
if {$inbraces} { |
||||
append token $c |
||||
} |
||||
} elseif {$c eq "\{"} { |
||||
incr inbraces |
||||
if {$inbraces} { |
||||
append token $c |
||||
} |
||||
} else { |
||||
append token $c |
||||
} |
||||
} |
||||
} elseif {$in_atom} { |
||||
#ignore dquotes/brackets in atoms - pass through |
||||
append token $c |
||||
#set nextc [lindex $chars $char_index+1] |
||||
if {$c eq "'"} { |
||||
set in_atom 0 |
||||
} |
||||
} elseif {$in_brackets > 0} { |
||||
append token $c |
||||
if {$c eq ")"} { |
||||
incr in_brackets -1 |
||||
} |
||||
} else { |
||||
if {$c eq {"}} { |
||||
if {!$inesc} { |
||||
set indq 1 |
||||
} else { |
||||
append token $c |
||||
} |
||||
} elseif {$c eq "\{"} { |
||||
if {!$inesc} { |
||||
set inbraces 1 |
||||
} else { |
||||
append token $c |
||||
} |
||||
} elseif {$c eq ","} { |
||||
#set var $token |
||||
#set spec "" |
||||
#if {$end_var_posn > 0} { |
||||
# #tcl scan with %s will not handle whitespace as desired. Be explicit using string range instead. |
||||
# #lassign [scan $token %${end_var_posn}s%s] var spec |
||||
# set var [string range $token 0 $end_var_posn-1] |
||||
# set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec |
||||
#} else { |
||||
# if {$end_var_posn == 0} { |
||||
# set var "" |
||||
# set spec $token |
||||
# } |
||||
#} |
||||
#lappend varlist [list [string trim $var] [string trim $spec]] |
||||
#set token "" |
||||
#set token_index -1 ;#reduce by 1 because , not included in next token |
||||
#set end_var_posn -1 |
||||
} else { |
||||
append token $c |
||||
switch -exact -- $c { |
||||
' { |
||||
set in_atom 1 |
||||
} |
||||
( { |
||||
incr in_brackets |
||||
} |
||||
default { |
||||
if {$end_var_posn == -1 && (($c in $var_terminals) && ($prevc ni $protect_terminals))} { |
||||
set end_var_posn $token_index |
||||
} |
||||
} |
||||
} |
||||
} |
||||
if {$c eq ","} { |
||||
set var $token |
||||
set spec "" |
||||
if {$end_var_posn > 0} { |
||||
#tcl scan with %s will not handle whitespace as desired. Be explicit using string range instead. |
||||
#lassign [scan $token %${end_var_posn}s%s] var spec |
||||
set var [string range $token 0 $end_var_posn-1] |
||||
set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec |
||||
} else { |
||||
if {$end_var_posn == 0} { |
||||
set var "" |
||||
set spec $token |
||||
} |
||||
} |
||||
lappend varlist [list [string trim $var] $spec] |
||||
set token "" |
||||
set token_index -1 |
||||
set end_var_posn -1 |
||||
|
||||
} |
||||
} |
||||
|
||||
if {$charcount == [string length $varspecs]} { |
||||
if {!($indq || $inbraces || $in_atom || $in_brackets)} { |
||||
if {$c ne ","} { |
||||
set var $token |
||||
set spec "" |
||||
if {$end_var_posn > 0} { |
||||
#tcl scan with %s will not handle whitespace as desired. Be explicit using string range instead. |
||||
#lassign [scan $token %${end_var_posn}s%s] var spec |
||||
set var [string range $token 0 $end_var_posn-1] |
||||
set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec |
||||
} else { |
||||
if {$end_var_posn == 0} { |
||||
set var "" |
||||
set spec $token |
||||
} |
||||
} |
||||
lappend varlist [list [string trim $var] $spec] |
||||
set token "" |
||||
set token_index -1 |
||||
set end_var_posn -1 |
||||
} |
||||
} |
||||
} |
||||
|
||||
set prevc $c |
||||
if {$c eq "\\"} { |
||||
#review |
||||
if {$inesc} { |
||||
set inesc 0 |
||||
} else { |
||||
set token [string range $token 0 end-1] |
||||
set inesc 1 |
||||
} |
||||
} else { |
||||
set inesc 0 |
||||
} |
||||
incr token_index |
||||
incr char_index |
||||
} |
||||
|
||||
#if {[string length $token]} { |
||||
# #lappend varlist [splitstrposn $token $end_var_posn] |
||||
# set var $token |
||||
# set spec "" |
||||
# if {$end_var_posn > 0} { |
||||
# #lassign [scan $token %${end_var_posn}s%s] var spec |
||||
# set var [string range $token 0 $end_var_posn-1] |
||||
# set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec |
||||
# } else { |
||||
# if {$end_var_posn == 0} { |
||||
# set var "" |
||||
# set spec $token |
||||
# } |
||||
# } |
||||
# #lappend varlist [list [string trim $var] [string trim $spec]] |
||||
# #spec needs to be able to match whitespace too |
||||
# lappend varlist [list [string trim $var] $spec] |
||||
#} |
||||
|
||||
return $varlist |
||||
} |
||||
|
||||
#todo - consider whether we can use < for insertion/iteration combinations |
||||
# =a<,b< iterate once through |
||||
# =a><,b>< cartesian product |
||||
# =a<>,b<> ??? zip ? |
||||
# |
||||
# ie = {a b c} |> .=< inspect |
||||
# would call inspect 3 times, once for each argument |
||||
# .= list {a b c} {x y z} |a/0,b/1> .=a><,b>< list |
||||
# would produce list of cartesian pairs? |
||||
# |
||||
proc _split_equalsrhs {insertionpattern} { |
||||
#map the insertionpattern so we can use faster globless info command search |
||||
set name_mapped [pipecmd_namemapping $insertionpattern] |
||||
set cmdname ::punk::pipecmds::split_rhs::_$name_mapped |
||||
if {[info commands $cmdname] ne ""} { |
||||
return [$cmdname] |
||||
} |
||||
|
||||
set lst_var_indexposition [_split_patterns_memoized $insertionpattern] |
||||
set i 0 |
||||
set return_triples [list] |
||||
foreach v_pos $lst_var_indexposition { |
||||
lassign $v_pos v index_and_position |
||||
#e.g varname@@data/ok>0 varname/1/0>end |
||||
#ensure only one ">" is detected |
||||
if {![string length $index_and_position]} { |
||||
set indexspec "" |
||||
set positionspec "" |
||||
} else { |
||||
set chars [split $index_and_position ""] |
||||
set posns [lsearch -all $chars ">"] |
||||
if {[llength $posns] > 1} { |
||||
error "pipesyntax error in segment insertion pattern '$insertionpattern' -v '$v' multiple '>' characters. Pattern not understood." "_split_equalsrhs $insertionpattern" [list pipesyntax insertionpattern_invalid] |
||||
} |
||||
if {![llength $posns]} { |
||||
set indexspec $index_and_position |
||||
set positionspec "" |
||||
} else { |
||||
set splitposn [lindex $posns 0] |
||||
set indexspec [string range $index_and_position 0 $splitposn-1] |
||||
set positionspec [string range $index_and_position $splitposn+1 end] |
||||
} |
||||
} |
||||
|
||||
#review - |
||||
if {($positionspec in [list "*" "/*" "@*" "/" "@"]) || ($v eq "*" && $positionspec eq "")} { |
||||
set star "" |
||||
if {$v eq "*"} { |
||||
set v "" |
||||
set star "*" |
||||
} |
||||
if {[string index $positionspec end] eq "*"} { |
||||
set star "*" |
||||
} |
||||
#it is always possible to insert at end of list regardless of current length - so /end* and @end* are equivalent |
||||
#as are /end and @end |
||||
#lset lst_var_indexposition $i [list $v "/end$star"] |
||||
set triple [list $v $indexspec "/end$star"] |
||||
} else { |
||||
if {$positionspec eq ""} { |
||||
#e.g just =varname |
||||
#lset lst_var_indexposition $i [list $v "/end"] |
||||
set triple [list $v $indexspec "/end"] |
||||
#error "pipesyntax error in segment insertionpattern '$insertionpattern' - v '$v' missing position spec e.g /0" |
||||
} else { |
||||
if {[string index $indexspec 0] ni [list "" "/" "@"]} { |
||||
error "pipesyntax error in segment insertionpattern '$insertionpattern' - v '$v' bad index spec '$indexspec'" "_split_equalsrhs $insertionpattern" [list pipesyntax insertionpattern_invalid] |
||||
} |
||||
set triple [list $v $indexspec $positionspec] |
||||
} |
||||
} |
||||
lappend return_triples $triple |
||||
incr i |
||||
} |
||||
proc $cmdname {} [list return $return_triples] |
||||
return $return_triples |
||||
} |
||||
|
||||
proc _rhs_tail_split {fullrhs} { |
||||
set inq 0; set indq 0 |
||||
set equalsrhs "" |
||||
set i 0 |
||||
foreach ch [split $fullrhs ""] { |
||||
if {$inq} { |
||||
append equalsrhs $ch |
||||
if {$ch eq {'}} { |
||||
set inq 0 |
||||
} |
||||
} elseif {$indq} { |
||||
append equalsrhs $ch |
||||
if {$ch eq {"}} { |
||||
set indq 0 |
||||
} |
||||
} else { |
||||
switch -- $ch { |
||||
{'} { |
||||
set inq 1 |
||||
} |
||||
{"} { |
||||
set indq 1 |
||||
} |
||||
" " { |
||||
#whitespace outside of quoting |
||||
break |
||||
} |
||||
0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 - a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - z {} |
||||
default { |
||||
#\t not a literal for switch jumpTable bytecompile - review - can we do it without for example string mapping to <t> (and without a literal binary tab in source file)? |
||||
#we can't (reliably?) put \t as one of our switch keys |
||||
# |
||||
if {$ch eq "\t"} { |
||||
break |
||||
} |
||||
} |
||||
} |
||||
append equalsrhs $ch |
||||
} |
||||
incr i |
||||
} |
||||
set tail [tcl::string::range $fullrhs $i end] |
||||
return [list $equalsrhs $tail] |
||||
} |
||||
|
||||
#todo - recurse into bracketed sub parts |
||||
#JMN3 |
||||
#e.g @*/(x@0,y@2) |
||||
proc _var_classify {multivar} { |
||||
set cmdname ::punk::pipecmds::var_classify::_[pipecmd_namemapping $multivar] |
||||
if {[info commands $cmdname] ne ""} { |
||||
return [$cmdname] |
||||
} |
||||
|
||||
|
||||
#comma seems a natural choice to split varspecs, |
||||
#but also for list and dict subelement access |
||||
#/ normally indicates some sort of hierarchical separation - (e.g in filesytems) |
||||
#so / will indicate subelements e.g @0/1 for lindex $list 0 1 |
||||
#set valsource_key_list [_split_var_key_at_unbracketed_comma $multivar] |
||||
set valsource_key_list [_split_patterns_memoized $multivar] |
||||
|
||||
|
||||
|
||||
#mutually exclusive - atom/pin |
||||
#set map [list "" ' ^ &] ;#0 = default/var/not-yet-determined 1 = atom 2 = pin |
||||
#set var_class [lmap var $valsource_key_list {expr {([set m [lsearch $map [string index [lindex $var 0] 0]]] >= 0) ? [list $var $m] : [list $var 0]}}] |
||||
#0 - novar |
||||
#1 - atom ' |
||||
#2 - pin ^ |
||||
#3 - boolean & |
||||
#4 - integer |
||||
#5 - double |
||||
#6 - var |
||||
#7 - glob (no classifier and contains * or ?) |
||||
#8 - numeric |
||||
#9 - > (+) |
||||
#10 - < (-) |
||||
|
||||
set var_names [list] |
||||
set var_class [list] |
||||
set varspecs_trimmed [list] ;#raw varspecs without pin/atom modifiers - or empty string for glob |
||||
|
||||
|
||||
set leading_classifiers [list "'" "&" "^" ] |
||||
set trailing_classifiers [list + -] |
||||
set possible_number_start [list - + . 0 1 2 3 4 5 6 7 8 9 > <] |
||||
|
||||
foreach v_key $valsource_key_list { |
||||
lassign $v_key v key |
||||
set vname $v ;#default |
||||
set classes [list] |
||||
if {$v eq ""} { |
||||
lappend var_class [list $v_key 0] |
||||
lappend varspecs_trimmed $v_key |
||||
} else { |
||||
set lastchar [string index $v end] |
||||
switch -- $lastchar { |
||||
+ { |
||||
lappend classes 9 |
||||
set vname [string range $v 0 end-1] |
||||
} |
||||
- { |
||||
lappend classes 10 |
||||
set vname [string range $v 0 end-1] |
||||
} |
||||
} |
||||
set firstchar [string index $v 0] |
||||
switch -- $firstchar { |
||||
' { |
||||
lappend var_class [list $v_key 1] |
||||
#set vname [string range $v 1 end] |
||||
lappend varspecs_trimmed [list $vname $key] |
||||
} |
||||
^ { |
||||
lappend classes [list 2] |
||||
#use vname - may already have trailing +/- stripped |
||||
set vname [string range $vname 1 end] |
||||
set secondclassifier [string index $v 1] |
||||
switch -- $secondclassifier { |
||||
"&" { |
||||
#pinned boolean |
||||
lappend classes 3 |
||||
set vname [string range $v 2 end] |
||||
} |
||||
"#" { |
||||
#pinned numeric comparison instead of string comparison |
||||
#e.g set x 2 |
||||
# this should match: ^#x.= list 2.0 |
||||
lappend classes 8 |
||||
set vname [string range $vname 1 end] |
||||
} |
||||
"*" { |
||||
#pinned glob |
||||
lappend classes 7 |
||||
set vname [string range $v 2 end] |
||||
} |
||||
} |
||||
#todo - check for second tag - & for pinned boolean? |
||||
#consider requiring ^# for numeric comparisons. currently no way to do a strictly string comparison on pinned variables.... default ^var really shouldn't be doing any magic. |
||||
#while we're at it.. pinned glob would be nice. ^* |
||||
#maybe even pinned scan ^% ? regex? ^/ or ^? these would be hard to have corresponding literals in the pattern mini-lang. |
||||
#These all limit the range of varnames permissible - which is no big deal. |
||||
lappend var_class [list $v_key $classes] |
||||
lappend varspecs_trimmed [list $vname $key] |
||||
} |
||||
& { |
||||
#we require boolean literals to be single-quoted so we can use cross-binding on boolean vars. |
||||
#ie &true is the variable true whereas &'true' or &'1' &'t' etc are literal booleans |
||||
#allow exception of &1 &0 to be literal booleans - because we disallow 0 & 1 as varnames in other contexts anyway - so it would be more consistent not to treat as varnames here. |
||||
lappend var_class [list $v_key 3] |
||||
set vname [string range $v 1 end] |
||||
lappend varspecs_trimmed [list $vname $key] |
||||
} |
||||
default { |
||||
if {([string first ? $v]) >=0 || ([string first * $v] >=0)} { |
||||
lappend var_class [list $v_key 7] ;#glob |
||||
#leave vname as the full glob |
||||
lappend varspecs_trimmed [list "" $key] |
||||
} else { |
||||
#scan vname not v - will either be same as v - or possibly stripped of trailing +/- |
||||
set numtestv [join [scan $vname %lld%s] ""] ;# handles octals (leading zeros), ok for use with bignums, decimal points and sci notation - fails to handle leading dot e.g .5 |
||||
#leading . still need to test directly for double |
||||
if {[string is double -strict $vname] || [string is double -strict $numtestv]} { |
||||
if {[string is integer -strict $numtestv]} { |
||||
#this will pick up boolean 1 or 0 - but that's ok - they require "&" marker if boolean comparison desired |
||||
#integer test before double.. |
||||
#note there is also string is wide (string is wideinteger) for larger ints.. |
||||
lappend classes 4 |
||||
lappend var_class [list $v_key $classes] |
||||
lappend varspecs_trimmed $v_key |
||||
} else { |
||||
#double |
||||
#sci notation 1e123 etc |
||||
#also large numbers like 1000000000 - even without decimal point - (tcl bignum) |
||||
lappend classes 5 |
||||
lappend var_class [list $v_key $classes] |
||||
lappend varspecs_trimmed $v_key |
||||
} |
||||
} else { |
||||
lappend var_class [list $v_key 6] ;#var |
||||
lappend varspecs_trimmed $v_key |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
lappend var_names $vname |
||||
} |
||||
|
||||
set result [list var_names $var_names var_class $var_class varspecs_trimmed $varspecs_trimmed] |
||||
|
||||
proc $cmdname {} [list return $result] |
||||
#JMN |
||||
#debug.punk.pipe.compile {proc $cmdname} |
||||
return $result |
||||
} |
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::pipe::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section Internal] |
||||
#tcl::namespace::eval punk::pipe::system { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::pipe::system}] |
||||
#[para] Internal functions that are not part of the API |
||||
|
||||
|
||||
|
||||
#} |
||||
|
||||
|
||||
# == === === === === === === === === === === === === === === |
||||
# Sample 'about' function with punk::args documentation |
||||
# == === === === === === === === === === === === === === === |
||||
tcl::namespace::eval punk::pipe { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
variable PUNKARGS |
||||
variable PUNKARGS_aliases |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id "(package)punk::pipe" |
||||
@package -name "punk::pipe" -help\ |
||||
"Package |
||||
Description" |
||||
}] |
||||
|
||||
namespace eval argdoc { |
||||
#namespace for custom argument documentation |
||||
proc package_name {} { |
||||
return punk::pipe |
||||
} |
||||
proc about_topics {} { |
||||
#info commands results are returned in an arbitrary order (like array keys) |
||||
set topic_funs [info commands [namespace current]::get_topic_*] |
||||
set about_topics [list] |
||||
foreach f $topic_funs { |
||||
set tail [namespace tail $f] |
||||
lappend about_topics [string range $tail [string length get_topic_] end] |
||||
} |
||||
return $about_topics |
||||
} |
||||
proc default_topics {} {return [list Description outline *]} |
||||
|
||||
# ------------------------------------------------------------- |
||||
# get_topic_ functions add more to auto-include in about topics |
||||
# ------------------------------------------------------------- |
||||
proc get_topic_Description {} { |
||||
punk::args::lib::tstr [string trim { |
||||
punk pipeline features |
||||
} \n] |
||||
} |
||||
proc get_topic_License {} { |
||||
return "MIT" |
||||
} |
||||
proc get_topic_Version {} { |
||||
return $::punk::pipe::version |
||||
} |
||||
proc get_topic_Contributors {} { |
||||
set authors {{Julian Noble <julian@precisium.com.au>}} |
||||
set contributors "" |
||||
foreach a $authors { |
||||
append contributors $a \n |
||||
} |
||||
if {[string index $contributors end] eq "\n"} { |
||||
set contributors [string range $contributors 0 end-1] |
||||
} |
||||
return $contributors |
||||
} |
||||
proc get_topic_outline {} { |
||||
punk::args::lib::tstr -return string { |
||||
todo.. |
||||
} |
||||
} |
||||
# ------------------------------------------------------------- |
||||
} |
||||
|
||||
# we re-use the argument definition from punk::args::standard_about and override some items |
||||
set overrides [dict create] |
||||
dict set overrides @id -id "::punk::pipe::about" |
||||
dict set overrides @cmd -name "punk::pipe::about" |
||||
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||
About punk::pipe |
||||
}] \n] |
||||
dict set overrides topic -choices [list {*}[punk::pipe::argdoc::about_topics] *] |
||||
dict set overrides topic -choicerestricted 1 |
||||
dict set overrides topic -default [punk::pipe::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict |
||||
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
||||
lappend PUNKARGS [list $newdef] |
||||
proc about {args} { |
||||
package require punk::args |
||||
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on |
||||
set argd [punk::args::parse $args withid ::punk::pipe::about] |
||||
lassign [dict values $argd] _leaders opts values _received |
||||
punk::args::package::standard_about -package_about_namespace ::punk::pipe::argdoc {*}$opts {*}[dict get $values topic] |
||||
} |
||||
} |
||||
# end of sample 'about' function |
||||
# == === === === === === === === === === === === === === === |
||||
|
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::punk::pipe |
||||
} |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::pipe [tcl::namespace::eval punk::pipe { |
||||
variable pkg punk::pipe |
||||
variable version |
||||
set version 1.0 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
Binary file not shown.
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,279 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2025 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::pcon 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license MIT |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin shellspy_module_punk::pcon 0 999999.0a1.0] |
||||
#[copyright "2025"] |
||||
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||
#[require punk::pcon] |
||||
#[keywords module] |
||||
#[description] |
||||
#[para] - |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of punk::pcon |
||||
#[subsection Concepts] |
||||
#[para] - |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by punk::pcon |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6- |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6}] |
||||
|
||||
# #package require frobz |
||||
# #*** !doctools |
||||
# #[item] [package {frobz}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# oo::class namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#tcl::namespace::eval punk::pcon::class { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::pcon::class}] |
||||
#[para] class definitions |
||||
#if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { |
||||
#*** !doctools |
||||
#[list_begin enumerated] |
||||
|
||||
# oo::class create interface_sample1 { |
||||
# #*** !doctools |
||||
# #[enum] CLASS [class interface_sample1] |
||||
# #[list_begin definitions] |
||||
|
||||
# method test {arg1} { |
||||
# #*** !doctools |
||||
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||
# #[para] test method |
||||
# puts "test: $arg1" |
||||
# } |
||||
|
||||
# #*** !doctools |
||||
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||
# } |
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end class enumeration ---}] |
||||
#} |
||||
#} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
tcl::namespace::eval punk::pcon { |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Base namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::pcon}] |
||||
#[para] Core API functions for punk::pcon |
||||
#[list_begin definitions] |
||||
|
||||
|
||||
|
||||
#proc sample1 {p1 n args} { |
||||
# #*** !doctools |
||||
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] |
||||
# #[para]Description of sample1 |
||||
# #[para] Arguments: |
||||
# # [list_begin arguments] |
||||
# # [arg_def tring p1] A description of string argument p1. |
||||
# # [arg_def integer n] A description of integer argument n. |
||||
# # [list_end] |
||||
# return "ok" |
||||
#} |
||||
|
||||
|
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::pcon ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::pcon::lib { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
tcl::namespace::path [tcl::namespace::parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::pcon::lib}] |
||||
#[para] Secondary functions that are part of the API |
||||
#[list_begin definitions] |
||||
|
||||
#proc utility1 {p1 args} { |
||||
# #*** !doctools |
||||
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||
# #[para]Description of utility1 |
||||
# return 1 |
||||
#} |
||||
|
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::pcon::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section Internal] |
||||
#tcl::namespace::eval punk::pcon::system { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::pcon::system}] |
||||
#[para] Internal functions that are not part of the API |
||||
|
||||
|
||||
|
||||
#} |
||||
|
||||
|
||||
# == === === === === === === === === === === === === === === |
||||
# Sample 'about' function with punk::args documentation |
||||
# == === === === === === === === === === === === === === === |
||||
tcl::namespace::eval punk::pcon { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
variable PUNKARGS |
||||
variable PUNKARGS_aliases |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id "(package)punk::pcon" |
||||
@package -name "punk::pcon" -help\ |
||||
"Package |
||||
Description" |
||||
}] |
||||
|
||||
namespace eval argdoc { |
||||
#namespace for custom argument documentation |
||||
proc package_name {} { |
||||
return punk::pcon |
||||
} |
||||
proc about_topics {} { |
||||
#info commands results are returned in an arbitrary order (like array keys) |
||||
set topic_funs [info commands [namespace current]::get_topic_*] |
||||
set about_topics [list] |
||||
foreach f $topic_funs { |
||||
set tail [namespace tail $f] |
||||
lappend about_topics [string range $tail [string length get_topic_] end] |
||||
} |
||||
#Adjust this function or 'default_topics' if a different order is required |
||||
return [lsort $about_topics] |
||||
} |
||||
proc default_topics {} {return [list Description *]} |
||||
|
||||
# ------------------------------------------------------------- |
||||
# get_topic_ functions add more to auto-include in about topics |
||||
# ------------------------------------------------------------- |
||||
proc get_topic_Description {} { |
||||
punk::args::lib::tstr [string trim { |
||||
package punk::pcon |
||||
description to come.. |
||||
} \n] |
||||
} |
||||
proc get_topic_License {} { |
||||
return "MIT" |
||||
} |
||||
proc get_topic_Version {} { |
||||
return "$::punk::pcon::version" |
||||
} |
||||
proc get_topic_Contributors {} { |
||||
set authors {{Julian Noble <julian@precisium.com.au>}} |
||||
set contributors "" |
||||
foreach a $authors { |
||||
append contributors $a \n |
||||
} |
||||
if {[string index $contributors end] eq "\n"} { |
||||
set contributors [string range $contributors 0 end-1] |
||||
} |
||||
return $contributors |
||||
} |
||||
proc get_topic_custom-topic {} { |
||||
punk::args::lib::tstr -return string { |
||||
A custom |
||||
topic |
||||
etc |
||||
} |
||||
} |
||||
# ------------------------------------------------------------- |
||||
} |
||||
|
||||
# we re-use the argument definition from punk::args::standard_about and override some items |
||||
set overrides [dict create] |
||||
dict set overrides @id -id "::punk::pcon::about" |
||||
dict set overrides @cmd -name "punk::pcon::about" |
||||
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||
About punk::pcon |
||||
}] \n] |
||||
dict set overrides topic -choices [list {*}[punk::pcon::argdoc::about_topics] *] |
||||
dict set overrides topic -choicerestricted 1 |
||||
dict set overrides topic -default [punk::pcon::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict |
||||
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
||||
lappend PUNKARGS [list $newdef] |
||||
proc about {args} { |
||||
package require punk::args |
||||
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on |
||||
set argd [punk::args::parse $args withid ::punk::pcon::about] |
||||
lassign [dict values $argd] _leaders opts values _received |
||||
punk::args::package::standard_about -package_about_namespace ::punk::pcon::argdoc {*}$opts {*}[dict get $values topic] |
||||
} |
||||
} |
||||
# end of sample 'about' function |
||||
# == === === === === === === === === === === === === === === |
||||
|
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::punk::pcon |
||||
} |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::pcon [tcl::namespace::eval punk::pcon { |
||||
variable pkg punk::pcon |
||||
variable version |
||||
set version 999999.0a1.0 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
@ -0,0 +1,3 @@
|
||||
1.0 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
@ -0,0 +1,853 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2025 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::pipe 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license MIT |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin shellspy_module_punk::pipe 0 999999.0a1.0] |
||||
#[copyright "2025"] |
||||
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||
#[require punk::pipe] |
||||
#[keywords module] |
||||
#[description] |
||||
#[para] - |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of punk::pipe |
||||
#[subsection Concepts] |
||||
#[para] - |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by punk::pipe |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6- |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6}] |
||||
|
||||
# #package require frobz |
||||
# #*** !doctools |
||||
# #[item] [package {frobz}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# oo::class namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#tcl::namespace::eval punk::pipe::class { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::pipe::class}] |
||||
#[para] class definitions |
||||
#if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { |
||||
#*** !doctools |
||||
#[list_begin enumerated] |
||||
|
||||
# oo::class create interface_sample1 { |
||||
# #*** !doctools |
||||
# #[enum] CLASS [class interface_sample1] |
||||
# #[list_begin definitions] |
||||
|
||||
# method test {arg1} { |
||||
# #*** !doctools |
||||
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||
# #[para] test method |
||||
# puts "test: $arg1" |
||||
# } |
||||
|
||||
# #*** !doctools |
||||
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||
# } |
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end class enumeration ---}] |
||||
#} |
||||
#} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
tcl::namespace::eval punk::pipe { |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Base namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::pipe}] |
||||
#[para] Core API functions for punk::pipe |
||||
#[list_begin definitions] |
||||
|
||||
|
||||
|
||||
#proc sample1 {p1 n args} { |
||||
# #*** !doctools |
||||
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] |
||||
# #[para]Description of sample1 |
||||
# #[para] Arguments: |
||||
# # [list_begin arguments] |
||||
# # [arg_def tring p1] A description of string argument p1. |
||||
# # [arg_def integer n] A description of integer argument n. |
||||
# # [list_end] |
||||
# return "ok" |
||||
#} |
||||
|
||||
#https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/ |
||||
# |
||||
#we can't provide a float comparison suitable for every situation, |
||||
#but we should pick something reasonable, keep it stable, and document it. |
||||
proc float_almost_equal {a b} { |
||||
package require math::constants |
||||
set diff [expr {abs($a - $b)}] |
||||
if {$diff <= $::math::constants::eps} { |
||||
return 1 |
||||
} |
||||
set A [expr {abs($a)}] |
||||
set B [expr {abs($b)}] |
||||
set largest [expr {($B > $A) ? $B : $A}] |
||||
return [expr {$diff <= $largest * $::math::constants::eps}] |
||||
} |
||||
|
||||
#debatable whether boolean_almost_equal is more surprising than helpful. |
||||
#values from a calculation that are extremely close to zero but aren't false could also be surprising - especially if they compare equal numerically |
||||
#perhaps a fuzzy-boolean is a step too far for a default - but it's inline with float-comparison for pattern-matching. |
||||
#alternatively - use an even more complex classifier? (^&~) ? |
||||
proc boolean_almost_equal {a b} { |
||||
if {[string is double -strict $a]} { |
||||
if {[float_almost_equal $a 0]} { |
||||
set a 0 |
||||
} |
||||
} |
||||
if {[string is double -strict $b]} { |
||||
if {[float_almost_equal $b 0]} { |
||||
set b 0 |
||||
} |
||||
} |
||||
#must handle true,no etc. |
||||
expr {($a && 1) == ($b && 1)} |
||||
} |
||||
|
||||
#boolean could be tr, true, y, ye, yes,Yes, 1 , 0 etc. |
||||
proc boolean_equal {a b} { |
||||
#equivalenttly xnor: expr {!(($a && 1) ^ ($b && 1))} ;# less clear and no discernable timing benefit. |
||||
expr {($a && 1) == ($b && 1)} |
||||
} |
||||
|
||||
|
||||
proc val [list [list v [lreplace x 0 0]]] {return $v} |
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::pipe ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::pipe::lib { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
tcl::namespace::path [tcl::namespace::parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::pipe::lib}] |
||||
#[para] Secondary functions that are part of the API |
||||
#[list_begin definitions] |
||||
|
||||
#proc utility1 {p1 args} { |
||||
# #*** !doctools |
||||
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||
# #[para]Description of utility1 |
||||
# return 1 |
||||
#} |
||||
|
||||
#map rhs to names suitable to use in pipemcd proc name (whitespace mapping) |
||||
# (for .= and = pipecmds) |
||||
proc pipecmd_namemapping {rhs} { |
||||
#used to build a command from a pattern which could contain :: - we need to map it to keep it a single command in the desired namespace. |
||||
#glob chars will prevent us using simple test {[info commands $cmd] eq ""} to test existence |
||||
#we could use the test {$cmd in [info commands]} - but mapping away globchars is more robust, allowing the simpler test |
||||
#set rhs [string trim $rhs];#ignore all leading & trailing whitespace |
||||
set rhs [string trimleft $rhs] |
||||
#--- |
||||
#REVIEW! |
||||
#set rhs [regsub -all {\s{1,}} $rhs {<sp>}] ;#collapse all internal whitespace to a single <sp> token |
||||
#This stops us matching {/@**@x x} vs {/@**@x x} |
||||
#--- |
||||
|
||||
set rhs [tcl::string::map {: <c> ? <q> * <star> [ <lb> ] <rb> \\ <bsl> {"} <dq> " " <sp>} $rhs] |
||||
#review - we don't expect other command-incompatible chars such as colon? |
||||
return $rhs |
||||
} |
||||
|
||||
# relatively slow on even small sized scripts |
||||
#proc arg_is_script_shaped2 {arg} { |
||||
# set re {^(\s|;|\n)$} |
||||
# set chars [split $arg ""] |
||||
# if {[lsearch -regex $chars $re] >=0} { |
||||
# return 1 |
||||
# } else { |
||||
# return 0 |
||||
# } |
||||
#} |
||||
|
||||
#exclude quoted whitespace |
||||
proc arg_is_script_shaped {arg} { |
||||
if {[tcl::string::first \n $arg] >= 0} { |
||||
return 1 |
||||
} elseif {[tcl::string::first ";" $arg] >= 0} { |
||||
return 1 |
||||
} elseif {[tcl::string::first " " $arg] >= 0 || [tcl::string::first \t $arg] >= 0} { |
||||
lassign [_rhs_tail_split $arg] _ part2 ;#will have part2 if unquoted whitespace found |
||||
return [expr {$part2 ne ""}] |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
|
||||
#split top level of patterns only. |
||||
proc _split_patterns_memoized {varspecs} { |
||||
set name_mapped [pipecmd_namemapping $varspecs] |
||||
set cmdname ::punk::pipecmds::split_patterns::_$name_mapped |
||||
if {[info commands $cmdname] ne ""} { |
||||
return [$cmdname] |
||||
} |
||||
set result [_split_patterns $varspecs] |
||||
proc $cmdname {} [list return $result] |
||||
#debug.punk.pipe.compile {proc $cmdname} 4 |
||||
return $result |
||||
} |
||||
|
||||
|
||||
#note - empty data after trailing , is ignored. (comma as very last character) |
||||
# - fix by documentation only. double up trailing comma e.g <pattern>,, if desired to return pattern match plus all at end! |
||||
#todo - move to punk::pipe |
||||
proc _split_patterns {varspecs} { |
||||
|
||||
set varlist [list] |
||||
# @ @@ - list and dict functions |
||||
# / level separator |
||||
# # list count, ## dict size |
||||
# % string functions |
||||
# ! not |
||||
set var_terminals [list "@" "/" "#" "%" "!" ">" "<"] ;# (> required for insertionspecs at rhs of = & .= ) |
||||
#right bracket ) also ends a var - but is different depending on whether var is array or basic. For array - it forms part of the varname |
||||
|
||||
#except when prefixed directly by pin classifier ^ |
||||
set protect_terminals [list "^"] ;# e.g sequence ^# |
||||
#also - an atom usually doesn't need the / as a terminal - because it can't match a missing element unless it's empty string |
||||
#ie the one usecase is '/n to match either empty string or missing item at position n. For this one usecase - we miss the capability to atom match paths/urls .. '/usr/local/et' |
||||
set in_brackets 0 ;#count depth |
||||
set in_atom 0 |
||||
set token "" |
||||
set end_var_posn -1 ;#first var_terminal encountered within each comma delimited section |
||||
set token_index 0 ;#index of terminal char within each token |
||||
set indq 0 |
||||
set inbraces 0 |
||||
set inesc 0 ;#whether last char was backslash (see also punk::escv) |
||||
set prevc "" |
||||
set char_index 0 |
||||
#if {[string index $varspecs end] eq ","} { |
||||
# set varspecs [string range $varspecs 0 end-1] |
||||
#} |
||||
set charcount 0 |
||||
foreach c [split $varspecs ""] { |
||||
incr charcount |
||||
if {$indq} { |
||||
if {$inesc} { |
||||
#puts stderr "inesc adding '$c'" |
||||
append token \\$c |
||||
} else { |
||||
if {$c eq {"}} { |
||||
set indq 0 |
||||
} else { |
||||
append token $c |
||||
} |
||||
} |
||||
} elseif {$inbraces} { |
||||
if {$inesc} { |
||||
append token \\$c |
||||
} else { |
||||
if {$c eq "\}"} { |
||||
incr inbraces -1 |
||||
if {$inbraces} { |
||||
append token $c |
||||
} |
||||
} elseif {$c eq "\{"} { |
||||
incr inbraces |
||||
if {$inbraces} { |
||||
append token $c |
||||
} |
||||
} else { |
||||
append token $c |
||||
} |
||||
} |
||||
} elseif {$in_atom} { |
||||
#ignore dquotes/brackets in atoms - pass through |
||||
append token $c |
||||
#set nextc [lindex $chars $char_index+1] |
||||
if {$c eq "'"} { |
||||
set in_atom 0 |
||||
} |
||||
} elseif {$in_brackets > 0} { |
||||
append token $c |
||||
if {$c eq ")"} { |
||||
incr in_brackets -1 |
||||
} |
||||
} else { |
||||
if {$c eq {"}} { |
||||
if {!$inesc} { |
||||
set indq 1 |
||||
} else { |
||||
append token $c |
||||
} |
||||
} elseif {$c eq "\{"} { |
||||
if {!$inesc} { |
||||
set inbraces 1 |
||||
} else { |
||||
append token $c |
||||
} |
||||
} elseif {$c eq ","} { |
||||
#set var $token |
||||
#set spec "" |
||||
#if {$end_var_posn > 0} { |
||||
# #tcl scan with %s will not handle whitespace as desired. Be explicit using string range instead. |
||||
# #lassign [scan $token %${end_var_posn}s%s] var spec |
||||
# set var [string range $token 0 $end_var_posn-1] |
||||
# set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec |
||||
#} else { |
||||
# if {$end_var_posn == 0} { |
||||
# set var "" |
||||
# set spec $token |
||||
# } |
||||
#} |
||||
#lappend varlist [list [string trim $var] [string trim $spec]] |
||||
#set token "" |
||||
#set token_index -1 ;#reduce by 1 because , not included in next token |
||||
#set end_var_posn -1 |
||||
} else { |
||||
append token $c |
||||
switch -exact -- $c { |
||||
' { |
||||
set in_atom 1 |
||||
} |
||||
( { |
||||
incr in_brackets |
||||
} |
||||
default { |
||||
if {$end_var_posn == -1 && (($c in $var_terminals) && ($prevc ni $protect_terminals))} { |
||||
set end_var_posn $token_index |
||||
} |
||||
} |
||||
} |
||||
} |
||||
if {$c eq ","} { |
||||
set var $token |
||||
set spec "" |
||||
if {$end_var_posn > 0} { |
||||
#tcl scan with %s will not handle whitespace as desired. Be explicit using string range instead. |
||||
#lassign [scan $token %${end_var_posn}s%s] var spec |
||||
set var [string range $token 0 $end_var_posn-1] |
||||
set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec |
||||
} else { |
||||
if {$end_var_posn == 0} { |
||||
set var "" |
||||
set spec $token |
||||
} |
||||
} |
||||
lappend varlist [list [string trim $var] $spec] |
||||
set token "" |
||||
set token_index -1 |
||||
set end_var_posn -1 |
||||
|
||||
} |
||||
} |
||||
|
||||
if {$charcount == [string length $varspecs]} { |
||||
if {!($indq || $inbraces || $in_atom || $in_brackets)} { |
||||
if {$c ne ","} { |
||||
set var $token |
||||
set spec "" |
||||
if {$end_var_posn > 0} { |
||||
#tcl scan with %s will not handle whitespace as desired. Be explicit using string range instead. |
||||
#lassign [scan $token %${end_var_posn}s%s] var spec |
||||
set var [string range $token 0 $end_var_posn-1] |
||||
set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec |
||||
} else { |
||||
if {$end_var_posn == 0} { |
||||
set var "" |
||||
set spec $token |
||||
} |
||||
} |
||||
lappend varlist [list [string trim $var] $spec] |
||||
set token "" |
||||
set token_index -1 |
||||
set end_var_posn -1 |
||||
} |
||||
} |
||||
} |
||||
|
||||
set prevc $c |
||||
if {$c eq "\\"} { |
||||
#review |
||||
if {$inesc} { |
||||
set inesc 0 |
||||
} else { |
||||
set token [string range $token 0 end-1] |
||||
set inesc 1 |
||||
} |
||||
} else { |
||||
set inesc 0 |
||||
} |
||||
incr token_index |
||||
incr char_index |
||||
} |
||||
|
||||
#if {[string length $token]} { |
||||
# #lappend varlist [splitstrposn $token $end_var_posn] |
||||
# set var $token |
||||
# set spec "" |
||||
# if {$end_var_posn > 0} { |
||||
# #lassign [scan $token %${end_var_posn}s%s] var spec |
||||
# set var [string range $token 0 $end_var_posn-1] |
||||
# set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec |
||||
# } else { |
||||
# if {$end_var_posn == 0} { |
||||
# set var "" |
||||
# set spec $token |
||||
# } |
||||
# } |
||||
# #lappend varlist [list [string trim $var] [string trim $spec]] |
||||
# #spec needs to be able to match whitespace too |
||||
# lappend varlist [list [string trim $var] $spec] |
||||
#} |
||||
|
||||
return $varlist |
||||
} |
||||
|
||||
#todo - consider whether we can use < for insertion/iteration combinations |
||||
# =a<,b< iterate once through |
||||
# =a><,b>< cartesian product |
||||
# =a<>,b<> ??? zip ? |
||||
# |
||||
# ie = {a b c} |> .=< inspect |
||||
# would call inspect 3 times, once for each argument |
||||
# .= list {a b c} {x y z} |a/0,b/1> .=a><,b>< list |
||||
# would produce list of cartesian pairs? |
||||
# |
||||
proc _split_equalsrhs {insertionpattern} { |
||||
#map the insertionpattern so we can use faster globless info command search |
||||
set name_mapped [pipecmd_namemapping $insertionpattern] |
||||
set cmdname ::punk::pipecmds::split_rhs::_$name_mapped |
||||
if {[info commands $cmdname] ne ""} { |
||||
return [$cmdname] |
||||
} |
||||
|
||||
set lst_var_indexposition [_split_patterns_memoized $insertionpattern] |
||||
set i 0 |
||||
set return_triples [list] |
||||
foreach v_pos $lst_var_indexposition { |
||||
lassign $v_pos v index_and_position |
||||
#e.g varname@@data/ok>0 varname/1/0>end |
||||
#ensure only one ">" is detected |
||||
if {![string length $index_and_position]} { |
||||
set indexspec "" |
||||
set positionspec "" |
||||
} else { |
||||
set chars [split $index_and_position ""] |
||||
set posns [lsearch -all $chars ">"] |
||||
if {[llength $posns] > 1} { |
||||
error "pipesyntax error in segment insertion pattern '$insertionpattern' -v '$v' multiple '>' characters. Pattern not understood." "_split_equalsrhs $insertionpattern" [list pipesyntax insertionpattern_invalid] |
||||
} |
||||
if {![llength $posns]} { |
||||
set indexspec $index_and_position |
||||
set positionspec "" |
||||
} else { |
||||
set splitposn [lindex $posns 0] |
||||
set indexspec [string range $index_and_position 0 $splitposn-1] |
||||
set positionspec [string range $index_and_position $splitposn+1 end] |
||||
} |
||||
} |
||||
|
||||
#review - |
||||
if {($positionspec in [list "*" "/*" "@*" "/" "@"]) || ($v eq "*" && $positionspec eq "")} { |
||||
set star "" |
||||
if {$v eq "*"} { |
||||
set v "" |
||||
set star "*" |
||||
} |
||||
if {[string index $positionspec end] eq "*"} { |
||||
set star "*" |
||||
} |
||||
#it is always possible to insert at end of list regardless of current length - so /end* and @end* are equivalent |
||||
#as are /end and @end |
||||
#lset lst_var_indexposition $i [list $v "/end$star"] |
||||
set triple [list $v $indexspec "/end$star"] |
||||
} else { |
||||
if {$positionspec eq ""} { |
||||
#e.g just =varname |
||||
#lset lst_var_indexposition $i [list $v "/end"] |
||||
set triple [list $v $indexspec "/end"] |
||||
#error "pipesyntax error in segment insertionpattern '$insertionpattern' - v '$v' missing position spec e.g /0" |
||||
} else { |
||||
if {[string index $indexspec 0] ni [list "" "/" "@"]} { |
||||
error "pipesyntax error in segment insertionpattern '$insertionpattern' - v '$v' bad index spec '$indexspec'" "_split_equalsrhs $insertionpattern" [list pipesyntax insertionpattern_invalid] |
||||
} |
||||
set triple [list $v $indexspec $positionspec] |
||||
} |
||||
} |
||||
lappend return_triples $triple |
||||
incr i |
||||
} |
||||
proc $cmdname {} [list return $return_triples] |
||||
return $return_triples |
||||
} |
||||
|
||||
proc _rhs_tail_split {fullrhs} { |
||||
set inq 0; set indq 0 |
||||
set equalsrhs "" |
||||
set i 0 |
||||
foreach ch [split $fullrhs ""] { |
||||
if {$inq} { |
||||
append equalsrhs $ch |
||||
if {$ch eq {'}} { |
||||
set inq 0 |
||||
} |
||||
} elseif {$indq} { |
||||
append equalsrhs $ch |
||||
if {$ch eq {"}} { |
||||
set indq 0 |
||||
} |
||||
} else { |
||||
switch -- $ch { |
||||
{'} { |
||||
set inq 1 |
||||
} |
||||
{"} { |
||||
set indq 1 |
||||
} |
||||
" " { |
||||
#whitespace outside of quoting |
||||
break |
||||
} |
||||
0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 - a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - z {} |
||||
default { |
||||
#\t not a literal for switch jumpTable bytecompile - review - can we do it without for example string mapping to <t> (and without a literal binary tab in source file)? |
||||
#we can't (reliably?) put \t as one of our switch keys |
||||
# |
||||
if {$ch eq "\t"} { |
||||
break |
||||
} |
||||
} |
||||
} |
||||
append equalsrhs $ch |
||||
} |
||||
incr i |
||||
} |
||||
set tail [tcl::string::range $fullrhs $i end] |
||||
return [list $equalsrhs $tail] |
||||
} |
||||
|
||||
#todo - recurse into bracketed sub parts |
||||
#JMN3 |
||||
#e.g @*/(x@0,y@2) |
||||
proc _var_classify {multivar} { |
||||
set cmdname ::punk::pipecmds::var_classify::_[pipecmd_namemapping $multivar] |
||||
if {[info commands $cmdname] ne ""} { |
||||
return [$cmdname] |
||||
} |
||||
|
||||
|
||||
#comma seems a natural choice to split varspecs, |
||||
#but also for list and dict subelement access |
||||
#/ normally indicates some sort of hierarchical separation - (e.g in filesytems) |
||||
#so / will indicate subelements e.g @0/1 for lindex $list 0 1 |
||||
#set valsource_key_list [_split_var_key_at_unbracketed_comma $multivar] |
||||
set valsource_key_list [_split_patterns_memoized $multivar] |
||||
|
||||
|
||||
|
||||
#mutually exclusive - atom/pin |
||||
#set map [list "" ' ^ &] ;#0 = default/var/not-yet-determined 1 = atom 2 = pin |
||||
#set var_class [lmap var $valsource_key_list {expr {([set m [lsearch $map [string index [lindex $var 0] 0]]] >= 0) ? [list $var $m] : [list $var 0]}}] |
||||
#0 - novar |
||||
#1 - atom ' |
||||
#2 - pin ^ |
||||
#3 - boolean & |
||||
#4 - integer |
||||
#5 - double |
||||
#6 - var |
||||
#7 - glob (no classifier and contains * or ?) |
||||
#8 - numeric |
||||
#9 - > (+) |
||||
#10 - < (-) |
||||
|
||||
set var_names [list] |
||||
set var_class [list] |
||||
set varspecs_trimmed [list] ;#raw varspecs without pin/atom modifiers - or empty string for glob |
||||
|
||||
|
||||
set leading_classifiers [list "'" "&" "^" ] |
||||
set trailing_classifiers [list + -] |
||||
set possible_number_start [list - + . 0 1 2 3 4 5 6 7 8 9 > <] |
||||
|
||||
foreach v_key $valsource_key_list { |
||||
lassign $v_key v key |
||||
set vname $v ;#default |
||||
set classes [list] |
||||
if {$v eq ""} { |
||||
lappend var_class [list $v_key 0] |
||||
lappend varspecs_trimmed $v_key |
||||
} else { |
||||
set lastchar [string index $v end] |
||||
switch -- $lastchar { |
||||
+ { |
||||
lappend classes 9 |
||||
set vname [string range $v 0 end-1] |
||||
} |
||||
- { |
||||
lappend classes 10 |
||||
set vname [string range $v 0 end-1] |
||||
} |
||||
} |
||||
set firstchar [string index $v 0] |
||||
switch -- $firstchar { |
||||
' { |
||||
lappend var_class [list $v_key 1] |
||||
#set vname [string range $v 1 end] |
||||
lappend varspecs_trimmed [list $vname $key] |
||||
} |
||||
^ { |
||||
lappend classes [list 2] |
||||
#use vname - may already have trailing +/- stripped |
||||
set vname [string range $vname 1 end] |
||||
set secondclassifier [string index $v 1] |
||||
switch -- $secondclassifier { |
||||
"&" { |
||||
#pinned boolean |
||||
lappend classes 3 |
||||
set vname [string range $v 2 end] |
||||
} |
||||
"#" { |
||||
#pinned numeric comparison instead of string comparison |
||||
#e.g set x 2 |
||||
# this should match: ^#x.= list 2.0 |
||||
lappend classes 8 |
||||
set vname [string range $vname 1 end] |
||||
} |
||||
"*" { |
||||
#pinned glob |
||||
lappend classes 7 |
||||
set vname [string range $v 2 end] |
||||
} |
||||
} |
||||
#todo - check for second tag - & for pinned boolean? |
||||
#consider requiring ^# for numeric comparisons. currently no way to do a strictly string comparison on pinned variables.... default ^var really shouldn't be doing any magic. |
||||
#while we're at it.. pinned glob would be nice. ^* |
||||
#maybe even pinned scan ^% ? regex? ^/ or ^? these would be hard to have corresponding literals in the pattern mini-lang. |
||||
#These all limit the range of varnames permissible - which is no big deal. |
||||
lappend var_class [list $v_key $classes] |
||||
lappend varspecs_trimmed [list $vname $key] |
||||
} |
||||
& { |
||||
#we require boolean literals to be single-quoted so we can use cross-binding on boolean vars. |
||||
#ie &true is the variable true whereas &'true' or &'1' &'t' etc are literal booleans |
||||
#allow exception of &1 &0 to be literal booleans - because we disallow 0 & 1 as varnames in other contexts anyway - so it would be more consistent not to treat as varnames here. |
||||
lappend var_class [list $v_key 3] |
||||
set vname [string range $v 1 end] |
||||
lappend varspecs_trimmed [list $vname $key] |
||||
} |
||||
default { |
||||
if {([string first ? $v]) >=0 || ([string first * $v] >=0)} { |
||||
lappend var_class [list $v_key 7] ;#glob |
||||
#leave vname as the full glob |
||||
lappend varspecs_trimmed [list "" $key] |
||||
} else { |
||||
#scan vname not v - will either be same as v - or possibly stripped of trailing +/- |
||||
set numtestv [join [scan $vname %lld%s] ""] ;# handles octals (leading zeros), ok for use with bignums, decimal points and sci notation - fails to handle leading dot e.g .5 |
||||
#leading . still need to test directly for double |
||||
if {[string is double -strict $vname] || [string is double -strict $numtestv]} { |
||||
if {[string is integer -strict $numtestv]} { |
||||
#this will pick up boolean 1 or 0 - but that's ok - they require "&" marker if boolean comparison desired |
||||
#integer test before double.. |
||||
#note there is also string is wide (string is wideinteger) for larger ints.. |
||||
lappend classes 4 |
||||
lappend var_class [list $v_key $classes] |
||||
lappend varspecs_trimmed $v_key |
||||
} else { |
||||
#double |
||||
#sci notation 1e123 etc |
||||
#also large numbers like 1000000000 - even without decimal point - (tcl bignum) |
||||
lappend classes 5 |
||||
lappend var_class [list $v_key $classes] |
||||
lappend varspecs_trimmed $v_key |
||||
} |
||||
} else { |
||||
lappend var_class [list $v_key 6] ;#var |
||||
lappend varspecs_trimmed $v_key |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
lappend var_names $vname |
||||
} |
||||
|
||||
set result [list var_names $var_names var_class $var_class varspecs_trimmed $varspecs_trimmed] |
||||
|
||||
proc $cmdname {} [list return $result] |
||||
#JMN |
||||
#debug.punk.pipe.compile {proc $cmdname} |
||||
return $result |
||||
} |
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::pipe::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section Internal] |
||||
#tcl::namespace::eval punk::pipe::system { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::pipe::system}] |
||||
#[para] Internal functions that are not part of the API |
||||
|
||||
|
||||
|
||||
#} |
||||
|
||||
|
||||
# == === === === === === === === === === === === === === === |
||||
# Sample 'about' function with punk::args documentation |
||||
# == === === === === === === === === === === === === === === |
||||
tcl::namespace::eval punk::pipe { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
variable PUNKARGS |
||||
variable PUNKARGS_aliases |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id "(package)punk::pipe" |
||||
@package -name "punk::pipe" -help\ |
||||
"Package |
||||
Description" |
||||
}] |
||||
|
||||
namespace eval argdoc { |
||||
#namespace for custom argument documentation |
||||
proc package_name {} { |
||||
return punk::pipe |
||||
} |
||||
proc about_topics {} { |
||||
#info commands results are returned in an arbitrary order (like array keys) |
||||
set topic_funs [info commands [namespace current]::get_topic_*] |
||||
set about_topics [list] |
||||
foreach f $topic_funs { |
||||
set tail [namespace tail $f] |
||||
lappend about_topics [string range $tail [string length get_topic_] end] |
||||
} |
||||
return $about_topics |
||||
} |
||||
proc default_topics {} {return [list Description outline *]} |
||||
|
||||
# ------------------------------------------------------------- |
||||
# get_topic_ functions add more to auto-include in about topics |
||||
# ------------------------------------------------------------- |
||||
proc get_topic_Description {} { |
||||
punk::args::lib::tstr [string trim { |
||||
punk pipeline features |
||||
} \n] |
||||
} |
||||
proc get_topic_License {} { |
||||
return "MIT" |
||||
} |
||||
proc get_topic_Version {} { |
||||
return $::punk::pipe::version |
||||
} |
||||
proc get_topic_Contributors {} { |
||||
set authors {{Julian Noble <julian@precisium.com.au>}} |
||||
set contributors "" |
||||
foreach a $authors { |
||||
append contributors $a \n |
||||
} |
||||
if {[string index $contributors end] eq "\n"} { |
||||
set contributors [string range $contributors 0 end-1] |
||||
} |
||||
return $contributors |
||||
} |
||||
proc get_topic_outline {} { |
||||
punk::args::lib::tstr -return string { |
||||
todo.. |
||||
} |
||||
} |
||||
# ------------------------------------------------------------- |
||||
} |
||||
|
||||
# we re-use the argument definition from punk::args::standard_about and override some items |
||||
set overrides [dict create] |
||||
dict set overrides @id -id "::punk::pipe::about" |
||||
dict set overrides @cmd -name "punk::pipe::about" |
||||
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||
About punk::pipe |
||||
}] \n] |
||||
dict set overrides topic -choices [list {*}[punk::pipe::argdoc::about_topics] *] |
||||
dict set overrides topic -choicerestricted 1 |
||||
dict set overrides topic -default [punk::pipe::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict |
||||
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
||||
lappend PUNKARGS [list $newdef] |
||||
proc about {args} { |
||||
package require punk::args |
||||
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on |
||||
set argd [punk::args::parse $args withid ::punk::pipe::about] |
||||
lassign [dict values $argd] _leaders opts values _received |
||||
punk::args::package::standard_about -package_about_namespace ::punk::pipe::argdoc {*}$opts {*}[dict get $values topic] |
||||
} |
||||
} |
||||
# end of sample 'about' function |
||||
# == === === === === === === === === === === === === === === |
||||
|
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::punk::pipe |
||||
} |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::pipe [tcl::namespace::eval punk::pipe { |
||||
variable pkg punk::pipe |
||||
variable version |
||||
set version 999999.0a1.0 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
@ -0,0 +1,3 @@
|
||||
1.0 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
@ -0,0 +1,568 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) Julian Noble 2024 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application argparsingtest 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license MIT |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin punkshell_module_argparsingtest 0 0.1.0] |
||||
#[copyright "2024"] |
||||
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||
#[require argparsingtest] |
||||
#[keywords module] |
||||
#[description] |
||||
#[para] - |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of argparsingtest |
||||
#[subsection Concepts] |
||||
#[para] - |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by argparsingtest |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6- |
||||
package require punk::args |
||||
package require struct::set |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6}] |
||||
#[item] [package {punk::args}] |
||||
|
||||
# #package require frobz |
||||
# #*** !doctools |
||||
# #[item] [package {frobz}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# oo::class namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval argparsingtest::class { |
||||
#*** !doctools |
||||
#[subsection {Namespace argparsingtest::class}] |
||||
#[para] class definitions |
||||
if {[info commands [namespace current]::interface_sample1] eq ""} { |
||||
#*** !doctools |
||||
#[list_begin enumerated] |
||||
|
||||
# oo::class create interface_sample1 { |
||||
# #*** !doctools |
||||
# #[enum] CLASS [class interface_sample1] |
||||
# #[list_begin definitions] |
||||
|
||||
# method test {arg1} { |
||||
# #*** !doctools |
||||
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||
# #[para] test method |
||||
# puts "test: $arg1" |
||||
# } |
||||
|
||||
# #*** !doctools |
||||
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||
# } |
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end class enumeration ---}] |
||||
} |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Base namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval argparsingtest { |
||||
namespace export {[a-z]*} ;# Convention: export all lowercase |
||||
#variable xyz |
||||
|
||||
#*** !doctools |
||||
#[subsection {Namespace argparsingtest}] |
||||
#[para] Core API functions for argparsingtest |
||||
#[list_begin definitions] |
||||
|
||||
proc test1_ni {args} { |
||||
set defaults [dict create\ |
||||
-return string\ |
||||
-frametype \uFFEF\ |
||||
-show_edge \uFFEF\ |
||||
-show_seps \uFFEF\ |
||||
-x ""\ |
||||
-y b\ |
||||
-z c\ |
||||
-1 1\ |
||||
-2 2\ |
||||
-3 3\ |
||||
] |
||||
foreach {k v} $args { |
||||
if {$k ni [dict keys $defaults]} { |
||||
error "unrecognised option '$k'. Known options [dict keys $defaults]" |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $args] |
||||
} |
||||
proc test1_switchmerge {args} { |
||||
set defaults [dict create\ |
||||
-return string\ |
||||
-frametype \uFFEF\ |
||||
-show_edge \uFFEF\ |
||||
-show_seps \uFFEF\ |
||||
-x ""\ |
||||
-y b\ |
||||
-z c\ |
||||
-1 1\ |
||||
-2 2\ |
||||
-3 3\ |
||||
] |
||||
foreach {k v} $args { |
||||
switch -- $k { |
||||
-return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 {} |
||||
default { |
||||
error "unrecognised option '$k'. Known options [dict keys $defaults]" |
||||
} |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $args] |
||||
} |
||||
#if we need to loop to test arg validity anyway - then dict set as we go is slightly faster than a dict merge at the end |
||||
proc test1_switch {args} { |
||||
set opts [dict create\ |
||||
-return string\ |
||||
-frametype \uFFEF\ |
||||
-show_edge \uFFEF\ |
||||
-show_seps \uFFEF\ |
||||
-x ""\ |
||||
-y b\ |
||||
-z c\ |
||||
-1 1\ |
||||
-2 2\ |
||||
-3 3\ |
||||
] |
||||
foreach {k v} $args { |
||||
switch -- $k { |
||||
-return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { |
||||
dict set opts $k $v |
||||
} |
||||
default { |
||||
error "unrecognised option '$k'. Known options [dict keys $opts]" |
||||
} |
||||
} |
||||
} |
||||
return $opts |
||||
} |
||||
variable switchopts |
||||
set switchopts [dict create\ |
||||
-return string\ |
||||
-frametype \uFFEF\ |
||||
-show_edge \uFFEF\ |
||||
-show_seps \uFFEF\ |
||||
-x ""\ |
||||
-y b\ |
||||
-z c\ |
||||
-1 1\ |
||||
-2 2\ |
||||
-3 3\ |
||||
] |
||||
#slightly slower than just creating the dict within the proc |
||||
proc test1_switch_nsvar {args} { |
||||
variable switchopts |
||||
set opts $switchopts |
||||
foreach {k v} $args { |
||||
switch -- $k { |
||||
-return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { |
||||
dict set opts $k $v |
||||
} |
||||
default { |
||||
error "unrecognised option '$k'. Known options [dict keys $opts]" |
||||
} |
||||
} |
||||
} |
||||
return $opts |
||||
} |
||||
proc test1_switch2 {args} { |
||||
set opts [dict create\ |
||||
-return string\ |
||||
-frametype \uFFEF\ |
||||
-show_edge \uFFEF\ |
||||
-show_seps \uFFEF\ |
||||
-x ""\ |
||||
-y b\ |
||||
-z c\ |
||||
-1 1\ |
||||
-2 2\ |
||||
-3 3\ |
||||
] |
||||
set switches [lmap v [dict keys $opts] {list $v -}] |
||||
set switches [concat {*}$switches] |
||||
set switches [lrange $switches 0 end-1] |
||||
foreach {k v} $args { |
||||
switch -- $k\ |
||||
{*}$switches { |
||||
dict set opts $k $v |
||||
}\ |
||||
default { |
||||
error "unrecognised option '$k'. Known options [dict keys $opts]" |
||||
} |
||||
} |
||||
return $opts |
||||
} |
||||
proc test1_prefix {args} { |
||||
set opts [dict create\ |
||||
-return string\ |
||||
-frametype \uFFEF\ |
||||
-show_edge \uFFEF\ |
||||
-show_seps \uFFEF\ |
||||
-x ""\ |
||||
-y b\ |
||||
-z c\ |
||||
-1 1\ |
||||
-2 2\ |
||||
-3 3\ |
||||
] |
||||
foreach {k v} $args { |
||||
dict set opts [tcl::prefix::match -message "test1_prefix option $k" {-return -frametype -show_edge -show_seps -x -y -z -1 -2 -3} $k] $v |
||||
} |
||||
return $opts |
||||
} |
||||
proc test1_prefix2 {args} { |
||||
set opts [dict create\ |
||||
-return string\ |
||||
-frametype \uFFEF\ |
||||
-show_edge \uFFEF\ |
||||
-show_seps \uFFEF\ |
||||
-x ""\ |
||||
-y b\ |
||||
-z c\ |
||||
-1 1\ |
||||
-2 2\ |
||||
-3 3\ |
||||
] |
||||
if {[llength $args]} { |
||||
set knownflags [dict keys $opts] |
||||
} |
||||
foreach {k v} $args { |
||||
dict set opts [tcl::prefix::match -message "test1_prefix2 option $k" $knownflags $k] $v |
||||
} |
||||
return $opts |
||||
} |
||||
|
||||
#punk::args is slower than argp - but comparable, and argp doesn't support solo flags |
||||
proc test1_punkargs {args} { |
||||
set argd [punk::args::parse $args withdef { |
||||
@id -id ::argparsingtest::test1_punkargs |
||||
@cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" |
||||
@opts -anyopts 0 |
||||
-return -default string -type string |
||||
-frametype -default \uFFEF -type string |
||||
-show_edge -default \uFFEF -type string |
||||
-show_seps -default \uFFEF -type string |
||||
-join -type none -multiple 1 |
||||
-x -default "" -type string |
||||
-y -default b -type string |
||||
-z -default c -type string |
||||
-1 -default 1 -type boolean |
||||
-2 -default 2 -type integer |
||||
-3 -default 3 -type integer |
||||
@values |
||||
}] |
||||
return [tcl::dict::get $argd opts] |
||||
} |
||||
|
||||
punk::args::define { |
||||
@id -id ::test1_punkargs_by_id |
||||
@cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" |
||||
@opts -anyopts 0 |
||||
-return -default string -type string |
||||
-frametype -default \uFFEF -type string |
||||
-show_edge -default \uFFEF -type string |
||||
-show_seps -default \uFFEF -type string |
||||
-join -type none -multiple 1 |
||||
-x -default "" -type string |
||||
-y -default b -type string |
||||
-z -default c -type string |
||||
-1 -default 1 -type boolean |
||||
-2 -default 2 -type integer |
||||
-3 -default 3 -type integer |
||||
@values |
||||
} |
||||
proc test1_punkargs_by_id {args} { |
||||
set argd [punk::args::get_by_id ::test1_punkargs_by_id $args] |
||||
return [tcl::dict::get $argd opts] |
||||
} |
||||
|
||||
punk::args::define { |
||||
@id -id ::argparsingtest::test1_punkargs2 |
||||
@cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" |
||||
@opts -anyopts 0 |
||||
-return -default string -type string |
||||
-frametype -default \uFFEF -type string |
||||
-show_edge -default \uFFEF -type string |
||||
-show_seps -default \uFFEF -type string |
||||
-join -type none -multiple 1 |
||||
-x -default "" -type string |
||||
-y -default b -type string |
||||
-z -default c -type string |
||||
-1 -default 1 -type boolean |
||||
-2 -default 2 -type integer |
||||
-3 -default 3 -type integer |
||||
@values |
||||
} |
||||
proc test1_punkargs2 {args} { |
||||
set argd [punk::args::get_by_id ::argparsingtest::test1_punkargs2 $args] |
||||
return [tcl::dict::get $argd opts] |
||||
} |
||||
|
||||
|
||||
proc test1_punkargs_validate_ansistripped {args} { |
||||
set argd [punk::args::get_dict { |
||||
@id -id ::argparsingtest::test1_punkargs_validate_ansistripped |
||||
@cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" |
||||
@opts -anyopts 0 |
||||
-return -default string -type string -choices {string object} -help "return type" |
||||
-frametype -default \uFFEF -type string |
||||
-show_edge -default \uFFEF -type string |
||||
-show_seps -default \uFFEF -type string |
||||
-join -type none -multiple 1 |
||||
-x -default "" -type string |
||||
-y -default b -type string |
||||
-z -default c -type string |
||||
-1 -default 1 -type boolean -validate_ansistripped true |
||||
-2 -default 2 -type integer -validate_ansistripped true |
||||
-3 -default 3 -type integer -validate_ansistripped true |
||||
@values |
||||
} $args] |
||||
return [tcl::dict::get $argd opts] |
||||
} |
||||
|
||||
package require opt |
||||
variable optlist |
||||
tcl::OptProc test1_opt { |
||||
{-return string "return type"} |
||||
{-frametype \uFFEF "type of frame"} |
||||
{-show_edge \uFFEF "show table outer borders"} |
||||
{-show_seps \uFFEF "show separators"} |
||||
{-join "solo option"} |
||||
{-x "" "x val"} |
||||
{-y b "y val"} |
||||
{-z c "z val"} |
||||
{-1 1 "1val"} |
||||
{-2 -int 2 "2val"} |
||||
{-3 -int 3 "3val"} |
||||
} { |
||||
set opts [dict create] |
||||
foreach v [info locals] { |
||||
dict set opts $v [set $v] |
||||
} |
||||
return $opts |
||||
} |
||||
|
||||
package require cmdline |
||||
#cmdline::getoptions is much faster than typedGetoptions |
||||
proc test1_cmdline_untyped {args} { |
||||
set cmdlineopts_untyped { |
||||
{return.arg "string" "return val"} |
||||
{frametype.arg \uFFEF "frame type"} |
||||
{show_edge.arg \uFFEF "show table borders"} |
||||
{show_seps.arg \uFFEF "show table seps"} |
||||
{join "join the things"} |
||||
{x.arg "" "arg x"} |
||||
{y.arg b "arg y"} |
||||
{z.arg c "arg z"} |
||||
{1.arg 1 "arg 1"} |
||||
{2.arg 2 "arg 2"} |
||||
{3.arg 3 "arg 3"} |
||||
} |
||||
|
||||
set usage "usage etc" |
||||
return [::cmdline::getoptions args $cmdlineopts_untyped $usage] |
||||
} |
||||
proc test1_cmdline_typed {args} { |
||||
set cmdlineopts_typed { |
||||
{return.arg "string" "return val"} |
||||
{frametype.arg \uFFEF "frame type"} |
||||
{show_edge.arg \uFFEF "show table borders"} |
||||
{show_seps.arg \uFFEF "show table seps"} |
||||
{join "join the things"} |
||||
{x.arg "" "arg x"} |
||||
{y.arg b "arg y"} |
||||
{z.arg c "arg z"} |
||||
{1.boolean 1 "arg 1"} |
||||
{2.integer 2 "arg 2"} |
||||
{3.integer 3 "arg 3"} |
||||
} |
||||
|
||||
set usage "usage etc" |
||||
return [::cmdline::typedGetoptions args $cmdlineopts_typed $usage] |
||||
} |
||||
|
||||
catch { |
||||
package require argp |
||||
argp::registerArgs test1_argp { |
||||
{ -return string "string" } |
||||
{ -frametype string \uFFEF } |
||||
{ -show_edge string \uFFEF } |
||||
{ -show_seps string \uFFEF } |
||||
{ -x string "" } |
||||
{ -y string b } |
||||
{ -z string c } |
||||
{ -1 boolean 1 } |
||||
{ -2 integer 2 } |
||||
{ -3 integer 3 } |
||||
} |
||||
} |
||||
proc test1_argp {args} { |
||||
argp::parseArgs opts |
||||
return [array get opts] |
||||
} |
||||
|
||||
package require tepam |
||||
tepam::procedure {test1_tepam} { |
||||
-args { |
||||
{-return -type string -default string} |
||||
{-frametype -type string -default \uFFEF} |
||||
{-show_edge -type string -default \uFFEF} |
||||
{-show_seps -type string -default \uFFEF} |
||||
{-join -type none -multiple} |
||||
{-x -type string -default ""} |
||||
{-y -type string -default b} |
||||
{-z -type string -default c} |
||||
{-1 -type boolean -default 1} |
||||
{-2 -type integer -default 2} |
||||
{-3 -type integer -default 3} |
||||
} |
||||
} { |
||||
return [dict create return $return frametype $frametype show_edge $show_edge show_seps $show_seps x $x y $y z $z 1 $1 2 $2 3 $3 join $join] |
||||
} |
||||
|
||||
#multiline values use first line of each record to determine amount of indent to trim |
||||
proc test_multiline {args} { |
||||
set t3 [textblock::frame t3] |
||||
set argd [punk::args::get_dict [subst { |
||||
-template1 -default { |
||||
****** |
||||
* t1 * |
||||
****** |
||||
} |
||||
-template2 -default { ------ |
||||
****** |
||||
* t2 * |
||||
******} |
||||
-template3 -default {$t3} |
||||
#substituted or literal values with newlines - no autoindent applied - caller will have to pad appropriately |
||||
-template3b -default { |
||||
$t3 |
||||
----------------- |
||||
$t3 |
||||
abc\ndef |
||||
} |
||||
-template4 -default "****** |
||||
* t4 * |
||||
******" |
||||
-template5 -default " |
||||
|
||||
|
||||
" |
||||
-flag -default 0 -type boolean |
||||
}] $args] |
||||
return $argd |
||||
} |
||||
|
||||
#proc sample1 {p1 n args} { |
||||
# #*** !doctools |
||||
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] |
||||
# #[para]Description of sample1 |
||||
# #[para] Arguments: |
||||
# # [list_begin arguments] |
||||
# # [arg_def tring p1] A description of string argument p1. |
||||
# # [arg_def integer n] A description of integer argument n. |
||||
# # [list_end] |
||||
# return "ok" |
||||
#} |
||||
|
||||
|
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace argparsingtest ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval argparsingtest::lib { |
||||
namespace export {[a-z]*} ;# Convention: export all lowercase |
||||
namespace path [namespace parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace argparsingtest::lib}] |
||||
#[para] Secondary functions that are part of the API |
||||
#[list_begin definitions] |
||||
|
||||
#proc utility1 {p1 args} { |
||||
# #*** !doctools |
||||
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||
# #[para]Description of utility1 |
||||
# return 1 |
||||
#} |
||||
|
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace argparsingtest::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section Internal] |
||||
namespace eval argparsingtest::system { |
||||
#*** !doctools |
||||
#[subsection {Namespace argparsingtest::system}] |
||||
#[para] Internal functions that are not part of the API |
||||
|
||||
|
||||
|
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide argparsingtest [namespace eval argparsingtest { |
||||
variable pkg argparsingtest |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,853 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2025 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::pipe 1.0 |
||||
# Meta platform tcl |
||||
# Meta license MIT |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin shellspy_module_punk::pipe 0 1.0] |
||||
#[copyright "2025"] |
||||
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||
#[require punk::pipe] |
||||
#[keywords module] |
||||
#[description] |
||||
#[para] - |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of punk::pipe |
||||
#[subsection Concepts] |
||||
#[para] - |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by punk::pipe |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6- |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6}] |
||||
|
||||
# #package require frobz |
||||
# #*** !doctools |
||||
# #[item] [package {frobz}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# oo::class namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#tcl::namespace::eval punk::pipe::class { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::pipe::class}] |
||||
#[para] class definitions |
||||
#if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { |
||||
#*** !doctools |
||||
#[list_begin enumerated] |
||||
|
||||
# oo::class create interface_sample1 { |
||||
# #*** !doctools |
||||
# #[enum] CLASS [class interface_sample1] |
||||
# #[list_begin definitions] |
||||
|
||||
# method test {arg1} { |
||||
# #*** !doctools |
||||
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||
# #[para] test method |
||||
# puts "test: $arg1" |
||||
# } |
||||
|
||||
# #*** !doctools |
||||
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||
# } |
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end class enumeration ---}] |
||||
#} |
||||
#} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
tcl::namespace::eval punk::pipe { |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Base namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::pipe}] |
||||
#[para] Core API functions for punk::pipe |
||||
#[list_begin definitions] |
||||
|
||||
|
||||
|
||||
#proc sample1 {p1 n args} { |
||||
# #*** !doctools |
||||
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] |
||||
# #[para]Description of sample1 |
||||
# #[para] Arguments: |
||||
# # [list_begin arguments] |
||||
# # [arg_def tring p1] A description of string argument p1. |
||||
# # [arg_def integer n] A description of integer argument n. |
||||
# # [list_end] |
||||
# return "ok" |
||||
#} |
||||
|
||||
#https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/ |
||||
# |
||||
#we can't provide a float comparison suitable for every situation, |
||||
#but we should pick something reasonable, keep it stable, and document it. |
||||
proc float_almost_equal {a b} { |
||||
package require math::constants |
||||
set diff [expr {abs($a - $b)}] |
||||
if {$diff <= $::math::constants::eps} { |
||||
return 1 |
||||
} |
||||
set A [expr {abs($a)}] |
||||
set B [expr {abs($b)}] |
||||
set largest [expr {($B > $A) ? $B : $A}] |
||||
return [expr {$diff <= $largest * $::math::constants::eps}] |
||||
} |
||||
|
||||
#debatable whether boolean_almost_equal is more surprising than helpful. |
||||
#values from a calculation that are extremely close to zero but aren't false could also be surprising - especially if they compare equal numerically |
||||
#perhaps a fuzzy-boolean is a step too far for a default - but it's inline with float-comparison for pattern-matching. |
||||
#alternatively - use an even more complex classifier? (^&~) ? |
||||
proc boolean_almost_equal {a b} { |
||||
if {[string is double -strict $a]} { |
||||
if {[float_almost_equal $a 0]} { |
||||
set a 0 |
||||
} |
||||
} |
||||
if {[string is double -strict $b]} { |
||||
if {[float_almost_equal $b 0]} { |
||||
set b 0 |
||||
} |
||||
} |
||||
#must handle true,no etc. |
||||
expr {($a && 1) == ($b && 1)} |
||||
} |
||||
|
||||
#boolean could be tr, true, y, ye, yes,Yes, 1 , 0 etc. |
||||
proc boolean_equal {a b} { |
||||
#equivalenttly xnor: expr {!(($a && 1) ^ ($b && 1))} ;# less clear and no discernable timing benefit. |
||||
expr {($a && 1) == ($b && 1)} |
||||
} |
||||
|
||||
|
||||
proc val [list [list v [lreplace x 0 0]]] {return $v} |
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::pipe ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::pipe::lib { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
tcl::namespace::path [tcl::namespace::parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::pipe::lib}] |
||||
#[para] Secondary functions that are part of the API |
||||
#[list_begin definitions] |
||||
|
||||
#proc utility1 {p1 args} { |
||||
# #*** !doctools |
||||
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||
# #[para]Description of utility1 |
||||
# return 1 |
||||
#} |
||||
|
||||
#map rhs to names suitable to use in pipemcd proc name (whitespace mapping) |
||||
# (for .= and = pipecmds) |
||||
proc pipecmd_namemapping {rhs} { |
||||
#used to build a command from a pattern which could contain :: - we need to map it to keep it a single command in the desired namespace. |
||||
#glob chars will prevent us using simple test {[info commands $cmd] eq ""} to test existence |
||||
#we could use the test {$cmd in [info commands]} - but mapping away globchars is more robust, allowing the simpler test |
||||
#set rhs [string trim $rhs];#ignore all leading & trailing whitespace |
||||
set rhs [string trimleft $rhs] |
||||
#--- |
||||
#REVIEW! |
||||
#set rhs [regsub -all {\s{1,}} $rhs {<sp>}] ;#collapse all internal whitespace to a single <sp> token |
||||
#This stops us matching {/@**@x x} vs {/@**@x x} |
||||
#--- |
||||
|
||||
set rhs [tcl::string::map {: <c> ? <q> * <star> [ <lb> ] <rb> \\ <bsl> {"} <dq> " " <sp>} $rhs] |
||||
#review - we don't expect other command-incompatible chars such as colon? |
||||
return $rhs |
||||
} |
||||
|
||||
# relatively slow on even small sized scripts |
||||
#proc arg_is_script_shaped2 {arg} { |
||||
# set re {^(\s|;|\n)$} |
||||
# set chars [split $arg ""] |
||||
# if {[lsearch -regex $chars $re] >=0} { |
||||
# return 1 |
||||
# } else { |
||||
# return 0 |
||||
# } |
||||
#} |
||||
|
||||
#exclude quoted whitespace |
||||
proc arg_is_script_shaped {arg} { |
||||
if {[tcl::string::first \n $arg] >= 0} { |
||||
return 1 |
||||
} elseif {[tcl::string::first ";" $arg] >= 0} { |
||||
return 1 |
||||
} elseif {[tcl::string::first " " $arg] >= 0 || [tcl::string::first \t $arg] >= 0} { |
||||
lassign [_rhs_tail_split $arg] _ part2 ;#will have part2 if unquoted whitespace found |
||||
return [expr {$part2 ne ""}] |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
|
||||
#split top level of patterns only. |
||||
proc _split_patterns_memoized {varspecs} { |
||||
set name_mapped [pipecmd_namemapping $varspecs] |
||||
set cmdname ::punk::pipecmds::split_patterns::_$name_mapped |
||||
if {[info commands $cmdname] ne ""} { |
||||
return [$cmdname] |
||||
} |
||||
set result [_split_patterns $varspecs] |
||||
proc $cmdname {} [list return $result] |
||||
#debug.punk.pipe.compile {proc $cmdname} 4 |
||||
return $result |
||||
} |
||||
|
||||
|
||||
#note - empty data after trailing , is ignored. (comma as very last character) |
||||
# - fix by documentation only. double up trailing comma e.g <pattern>,, if desired to return pattern match plus all at end! |
||||
#todo - move to punk::pipe |
||||
proc _split_patterns {varspecs} { |
||||
|
||||
set varlist [list] |
||||
# @ @@ - list and dict functions |
||||
# / level separator |
||||
# # list count, ## dict size |
||||
# % string functions |
||||
# ! not |
||||
set var_terminals [list "@" "/" "#" "%" "!" ">" "<"] ;# (> required for insertionspecs at rhs of = & .= ) |
||||
#right bracket ) also ends a var - but is different depending on whether var is array or basic. For array - it forms part of the varname |
||||
|
||||
#except when prefixed directly by pin classifier ^ |
||||
set protect_terminals [list "^"] ;# e.g sequence ^# |
||||
#also - an atom usually doesn't need the / as a terminal - because it can't match a missing element unless it's empty string |
||||
#ie the one usecase is '/n to match either empty string or missing item at position n. For this one usecase - we miss the capability to atom match paths/urls .. '/usr/local/et' |
||||
set in_brackets 0 ;#count depth |
||||
set in_atom 0 |
||||
set token "" |
||||
set end_var_posn -1 ;#first var_terminal encountered within each comma delimited section |
||||
set token_index 0 ;#index of terminal char within each token |
||||
set indq 0 |
||||
set inbraces 0 |
||||
set inesc 0 ;#whether last char was backslash (see also punk::escv) |
||||
set prevc "" |
||||
set char_index 0 |
||||
#if {[string index $varspecs end] eq ","} { |
||||
# set varspecs [string range $varspecs 0 end-1] |
||||
#} |
||||
set charcount 0 |
||||
foreach c [split $varspecs ""] { |
||||
incr charcount |
||||
if {$indq} { |
||||
if {$inesc} { |
||||
#puts stderr "inesc adding '$c'" |
||||
append token \\$c |
||||
} else { |
||||
if {$c eq {"}} { |
||||
set indq 0 |
||||
} else { |
||||
append token $c |
||||
} |
||||
} |
||||
} elseif {$inbraces} { |
||||
if {$inesc} { |
||||
append token \\$c |
||||
} else { |
||||
if {$c eq "\}"} { |
||||
incr inbraces -1 |
||||
if {$inbraces} { |
||||
append token $c |
||||
} |
||||
} elseif {$c eq "\{"} { |
||||
incr inbraces |
||||
if {$inbraces} { |
||||
append token $c |
||||
} |
||||
} else { |
||||
append token $c |
||||
} |
||||
} |
||||
} elseif {$in_atom} { |
||||
#ignore dquotes/brackets in atoms - pass through |
||||
append token $c |
||||
#set nextc [lindex $chars $char_index+1] |
||||
if {$c eq "'"} { |
||||
set in_atom 0 |
||||
} |
||||
} elseif {$in_brackets > 0} { |
||||
append token $c |
||||
if {$c eq ")"} { |
||||
incr in_brackets -1 |
||||
} |
||||
} else { |
||||
if {$c eq {"}} { |
||||
if {!$inesc} { |
||||
set indq 1 |
||||
} else { |
||||
append token $c |
||||
} |
||||
} elseif {$c eq "\{"} { |
||||
if {!$inesc} { |
||||
set inbraces 1 |
||||
} else { |
||||
append token $c |
||||
} |
||||
} elseif {$c eq ","} { |
||||
#set var $token |
||||
#set spec "" |
||||
#if {$end_var_posn > 0} { |
||||
# #tcl scan with %s will not handle whitespace as desired. Be explicit using string range instead. |
||||
# #lassign [scan $token %${end_var_posn}s%s] var spec |
||||
# set var [string range $token 0 $end_var_posn-1] |
||||
# set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec |
||||
#} else { |
||||
# if {$end_var_posn == 0} { |
||||
# set var "" |
||||
# set spec $token |
||||
# } |
||||
#} |
||||
#lappend varlist [list [string trim $var] [string trim $spec]] |
||||
#set token "" |
||||
#set token_index -1 ;#reduce by 1 because , not included in next token |
||||
#set end_var_posn -1 |
||||
} else { |
||||
append token $c |
||||
switch -exact -- $c { |
||||
' { |
||||
set in_atom 1 |
||||
} |
||||
( { |
||||
incr in_brackets |
||||
} |
||||
default { |
||||
if {$end_var_posn == -1 && (($c in $var_terminals) && ($prevc ni $protect_terminals))} { |
||||
set end_var_posn $token_index |
||||
} |
||||
} |
||||
} |
||||
} |
||||
if {$c eq ","} { |
||||
set var $token |
||||
set spec "" |
||||
if {$end_var_posn > 0} { |
||||
#tcl scan with %s will not handle whitespace as desired. Be explicit using string range instead. |
||||
#lassign [scan $token %${end_var_posn}s%s] var spec |
||||
set var [string range $token 0 $end_var_posn-1] |
||||
set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec |
||||
} else { |
||||
if {$end_var_posn == 0} { |
||||
set var "" |
||||
set spec $token |
||||
} |
||||
} |
||||
lappend varlist [list [string trim $var] $spec] |
||||
set token "" |
||||
set token_index -1 |
||||
set end_var_posn -1 |
||||
|
||||
} |
||||
} |
||||
|
||||
if {$charcount == [string length $varspecs]} { |
||||
if {!($indq || $inbraces || $in_atom || $in_brackets)} { |
||||
if {$c ne ","} { |
||||
set var $token |
||||
set spec "" |
||||
if {$end_var_posn > 0} { |
||||
#tcl scan with %s will not handle whitespace as desired. Be explicit using string range instead. |
||||
#lassign [scan $token %${end_var_posn}s%s] var spec |
||||
set var [string range $token 0 $end_var_posn-1] |
||||
set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec |
||||
} else { |
||||
if {$end_var_posn == 0} { |
||||
set var "" |
||||
set spec $token |
||||
} |
||||
} |
||||
lappend varlist [list [string trim $var] $spec] |
||||
set token "" |
||||
set token_index -1 |
||||
set end_var_posn -1 |
||||
} |
||||
} |
||||
} |
||||
|
||||
set prevc $c |
||||
if {$c eq "\\"} { |
||||
#review |
||||
if {$inesc} { |
||||
set inesc 0 |
||||
} else { |
||||
set token [string range $token 0 end-1] |
||||
set inesc 1 |
||||
} |
||||
} else { |
||||
set inesc 0 |
||||
} |
||||
incr token_index |
||||
incr char_index |
||||
} |
||||
|
||||
#if {[string length $token]} { |
||||
# #lappend varlist [splitstrposn $token $end_var_posn] |
||||
# set var $token |
||||
# set spec "" |
||||
# if {$end_var_posn > 0} { |
||||
# #lassign [scan $token %${end_var_posn}s%s] var spec |
||||
# set var [string range $token 0 $end_var_posn-1] |
||||
# set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec |
||||
# } else { |
||||
# if {$end_var_posn == 0} { |
||||
# set var "" |
||||
# set spec $token |
||||
# } |
||||
# } |
||||
# #lappend varlist [list [string trim $var] [string trim $spec]] |
||||
# #spec needs to be able to match whitespace too |
||||
# lappend varlist [list [string trim $var] $spec] |
||||
#} |
||||
|
||||
return $varlist |
||||
} |
||||
|
||||
#todo - consider whether we can use < for insertion/iteration combinations |
||||
# =a<,b< iterate once through |
||||
# =a><,b>< cartesian product |
||||
# =a<>,b<> ??? zip ? |
||||
# |
||||
# ie = {a b c} |> .=< inspect |
||||
# would call inspect 3 times, once for each argument |
||||
# .= list {a b c} {x y z} |a/0,b/1> .=a><,b>< list |
||||
# would produce list of cartesian pairs? |
||||
# |
||||
proc _split_equalsrhs {insertionpattern} { |
||||
#map the insertionpattern so we can use faster globless info command search |
||||
set name_mapped [pipecmd_namemapping $insertionpattern] |
||||
set cmdname ::punk::pipecmds::split_rhs::_$name_mapped |
||||
if {[info commands $cmdname] ne ""} { |
||||
return [$cmdname] |
||||
} |
||||
|
||||
set lst_var_indexposition [_split_patterns_memoized $insertionpattern] |
||||
set i 0 |
||||
set return_triples [list] |
||||
foreach v_pos $lst_var_indexposition { |
||||
lassign $v_pos v index_and_position |
||||
#e.g varname@@data/ok>0 varname/1/0>end |
||||
#ensure only one ">" is detected |
||||
if {![string length $index_and_position]} { |
||||
set indexspec "" |
||||
set positionspec "" |
||||
} else { |
||||
set chars [split $index_and_position ""] |
||||
set posns [lsearch -all $chars ">"] |
||||
if {[llength $posns] > 1} { |
||||
error "pipesyntax error in segment insertion pattern '$insertionpattern' -v '$v' multiple '>' characters. Pattern not understood." "_split_equalsrhs $insertionpattern" [list pipesyntax insertionpattern_invalid] |
||||
} |
||||
if {![llength $posns]} { |
||||
set indexspec $index_and_position |
||||
set positionspec "" |
||||
} else { |
||||
set splitposn [lindex $posns 0] |
||||
set indexspec [string range $index_and_position 0 $splitposn-1] |
||||
set positionspec [string range $index_and_position $splitposn+1 end] |
||||
} |
||||
} |
||||
|
||||
#review - |
||||
if {($positionspec in [list "*" "/*" "@*" "/" "@"]) || ($v eq "*" && $positionspec eq "")} { |
||||
set star "" |
||||
if {$v eq "*"} { |
||||
set v "" |
||||
set star "*" |
||||
} |
||||
if {[string index $positionspec end] eq "*"} { |
||||
set star "*" |
||||
} |
||||
#it is always possible to insert at end of list regardless of current length - so /end* and @end* are equivalent |
||||
#as are /end and @end |
||||
#lset lst_var_indexposition $i [list $v "/end$star"] |
||||
set triple [list $v $indexspec "/end$star"] |
||||
} else { |
||||
if {$positionspec eq ""} { |
||||
#e.g just =varname |
||||
#lset lst_var_indexposition $i [list $v "/end"] |
||||
set triple [list $v $indexspec "/end"] |
||||
#error "pipesyntax error in segment insertionpattern '$insertionpattern' - v '$v' missing position spec e.g /0" |
||||
} else { |
||||
if {[string index $indexspec 0] ni [list "" "/" "@"]} { |
||||
error "pipesyntax error in segment insertionpattern '$insertionpattern' - v '$v' bad index spec '$indexspec'" "_split_equalsrhs $insertionpattern" [list pipesyntax insertionpattern_invalid] |
||||
} |
||||
set triple [list $v $indexspec $positionspec] |
||||
} |
||||
} |
||||
lappend return_triples $triple |
||||
incr i |
||||
} |
||||
proc $cmdname {} [list return $return_triples] |
||||
return $return_triples |
||||
} |
||||
|
||||
proc _rhs_tail_split {fullrhs} { |
||||
set inq 0; set indq 0 |
||||
set equalsrhs "" |
||||
set i 0 |
||||
foreach ch [split $fullrhs ""] { |
||||
if {$inq} { |
||||
append equalsrhs $ch |
||||
if {$ch eq {'}} { |
||||
set inq 0 |
||||
} |
||||
} elseif {$indq} { |
||||
append equalsrhs $ch |
||||
if {$ch eq {"}} { |
||||
set indq 0 |
||||
} |
||||
} else { |
||||
switch -- $ch { |
||||
{'} { |
||||
set inq 1 |
||||
} |
||||
{"} { |
||||
set indq 1 |
||||
} |
||||
" " { |
||||
#whitespace outside of quoting |
||||
break |
||||
} |
||||
0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 - a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - z {} |
||||
default { |
||||
#\t not a literal for switch jumpTable bytecompile - review - can we do it without for example string mapping to <t> (and without a literal binary tab in source file)? |
||||
#we can't (reliably?) put \t as one of our switch keys |
||||
# |
||||
if {$ch eq "\t"} { |
||||
break |
||||
} |
||||
} |
||||
} |
||||
append equalsrhs $ch |
||||
} |
||||
incr i |
||||
} |
||||
set tail [tcl::string::range $fullrhs $i end] |
||||
return [list $equalsrhs $tail] |
||||
} |
||||
|
||||
#todo - recurse into bracketed sub parts |
||||
#JMN3 |
||||
#e.g @*/(x@0,y@2) |
||||
proc _var_classify {multivar} { |
||||
set cmdname ::punk::pipecmds::var_classify::_[pipecmd_namemapping $multivar] |
||||
if {[info commands $cmdname] ne ""} { |
||||
return [$cmdname] |
||||
} |
||||
|
||||
|
||||
#comma seems a natural choice to split varspecs, |
||||
#but also for list and dict subelement access |
||||
#/ normally indicates some sort of hierarchical separation - (e.g in filesytems) |
||||
#so / will indicate subelements e.g @0/1 for lindex $list 0 1 |
||||
#set valsource_key_list [_split_var_key_at_unbracketed_comma $multivar] |
||||
set valsource_key_list [_split_patterns_memoized $multivar] |
||||
|
||||
|
||||
|
||||
#mutually exclusive - atom/pin |
||||
#set map [list "" ' ^ &] ;#0 = default/var/not-yet-determined 1 = atom 2 = pin |
||||
#set var_class [lmap var $valsource_key_list {expr {([set m [lsearch $map [string index [lindex $var 0] 0]]] >= 0) ? [list $var $m] : [list $var 0]}}] |
||||
#0 - novar |
||||
#1 - atom ' |
||||
#2 - pin ^ |
||||
#3 - boolean & |
||||
#4 - integer |
||||
#5 - double |
||||
#6 - var |
||||
#7 - glob (no classifier and contains * or ?) |
||||
#8 - numeric |
||||
#9 - > (+) |
||||
#10 - < (-) |
||||
|
||||
set var_names [list] |
||||
set var_class [list] |
||||
set varspecs_trimmed [list] ;#raw varspecs without pin/atom modifiers - or empty string for glob |
||||
|
||||
|
||||
set leading_classifiers [list "'" "&" "^" ] |
||||
set trailing_classifiers [list + -] |
||||
set possible_number_start [list - + . 0 1 2 3 4 5 6 7 8 9 > <] |
||||
|
||||
foreach v_key $valsource_key_list { |
||||
lassign $v_key v key |
||||
set vname $v ;#default |
||||
set classes [list] |
||||
if {$v eq ""} { |
||||
lappend var_class [list $v_key 0] |
||||
lappend varspecs_trimmed $v_key |
||||
} else { |
||||
set lastchar [string index $v end] |
||||
switch -- $lastchar { |
||||
+ { |
||||
lappend classes 9 |
||||
set vname [string range $v 0 end-1] |
||||
} |
||||
- { |
||||
lappend classes 10 |
||||
set vname [string range $v 0 end-1] |
||||
} |
||||
} |
||||
set firstchar [string index $v 0] |
||||
switch -- $firstchar { |
||||
' { |
||||
lappend var_class [list $v_key 1] |
||||
#set vname [string range $v 1 end] |
||||
lappend varspecs_trimmed [list $vname $key] |
||||
} |
||||
^ { |
||||
lappend classes [list 2] |
||||
#use vname - may already have trailing +/- stripped |
||||
set vname [string range $vname 1 end] |
||||
set secondclassifier [string index $v 1] |
||||
switch -- $secondclassifier { |
||||
"&" { |
||||
#pinned boolean |
||||
lappend classes 3 |
||||
set vname [string range $v 2 end] |
||||
} |
||||
"#" { |
||||
#pinned numeric comparison instead of string comparison |
||||
#e.g set x 2 |
||||
# this should match: ^#x.= list 2.0 |
||||
lappend classes 8 |
||||
set vname [string range $vname 1 end] |
||||
} |
||||
"*" { |
||||
#pinned glob |
||||
lappend classes 7 |
||||
set vname [string range $v 2 end] |
||||
} |
||||
} |
||||
#todo - check for second tag - & for pinned boolean? |
||||
#consider requiring ^# for numeric comparisons. currently no way to do a strictly string comparison on pinned variables.... default ^var really shouldn't be doing any magic. |
||||
#while we're at it.. pinned glob would be nice. ^* |
||||
#maybe even pinned scan ^% ? regex? ^/ or ^? these would be hard to have corresponding literals in the pattern mini-lang. |
||||
#These all limit the range of varnames permissible - which is no big deal. |
||||
lappend var_class [list $v_key $classes] |
||||
lappend varspecs_trimmed [list $vname $key] |
||||
} |
||||
& { |
||||
#we require boolean literals to be single-quoted so we can use cross-binding on boolean vars. |
||||
#ie &true is the variable true whereas &'true' or &'1' &'t' etc are literal booleans |
||||
#allow exception of &1 &0 to be literal booleans - because we disallow 0 & 1 as varnames in other contexts anyway - so it would be more consistent not to treat as varnames here. |
||||
lappend var_class [list $v_key 3] |
||||
set vname [string range $v 1 end] |
||||
lappend varspecs_trimmed [list $vname $key] |
||||
} |
||||
default { |
||||
if {([string first ? $v]) >=0 || ([string first * $v] >=0)} { |
||||
lappend var_class [list $v_key 7] ;#glob |
||||
#leave vname as the full glob |
||||
lappend varspecs_trimmed [list "" $key] |
||||
} else { |
||||
#scan vname not v - will either be same as v - or possibly stripped of trailing +/- |
||||
set numtestv [join [scan $vname %lld%s] ""] ;# handles octals (leading zeros), ok for use with bignums, decimal points and sci notation - fails to handle leading dot e.g .5 |
||||
#leading . still need to test directly for double |
||||
if {[string is double -strict $vname] || [string is double -strict $numtestv]} { |
||||
if {[string is integer -strict $numtestv]} { |
||||
#this will pick up boolean 1 or 0 - but that's ok - they require "&" marker if boolean comparison desired |
||||
#integer test before double.. |
||||
#note there is also string is wide (string is wideinteger) for larger ints.. |
||||
lappend classes 4 |
||||
lappend var_class [list $v_key $classes] |
||||
lappend varspecs_trimmed $v_key |
||||
} else { |
||||
#double |
||||
#sci notation 1e123 etc |
||||
#also large numbers like 1000000000 - even without decimal point - (tcl bignum) |
||||
lappend classes 5 |
||||
lappend var_class [list $v_key $classes] |
||||
lappend varspecs_trimmed $v_key |
||||
} |
||||
} else { |
||||
lappend var_class [list $v_key 6] ;#var |
||||
lappend varspecs_trimmed $v_key |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
lappend var_names $vname |
||||
} |
||||
|
||||
set result [list var_names $var_names var_class $var_class varspecs_trimmed $varspecs_trimmed] |
||||
|
||||
proc $cmdname {} [list return $result] |
||||
#JMN |
||||
#debug.punk.pipe.compile {proc $cmdname} |
||||
return $result |
||||
} |
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::pipe::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section Internal] |
||||
#tcl::namespace::eval punk::pipe::system { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::pipe::system}] |
||||
#[para] Internal functions that are not part of the API |
||||
|
||||
|
||||
|
||||
#} |
||||
|
||||
|
||||
# == === === === === === === === === === === === === === === |
||||
# Sample 'about' function with punk::args documentation |
||||
# == === === === === === === === === === === === === === === |
||||
tcl::namespace::eval punk::pipe { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
variable PUNKARGS |
||||
variable PUNKARGS_aliases |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id "(package)punk::pipe" |
||||
@package -name "punk::pipe" -help\ |
||||
"Package |
||||
Description" |
||||
}] |
||||
|
||||
namespace eval argdoc { |
||||
#namespace for custom argument documentation |
||||
proc package_name {} { |
||||
return punk::pipe |
||||
} |
||||
proc about_topics {} { |
||||
#info commands results are returned in an arbitrary order (like array keys) |
||||
set topic_funs [info commands [namespace current]::get_topic_*] |
||||
set about_topics [list] |
||||
foreach f $topic_funs { |
||||
set tail [namespace tail $f] |
||||
lappend about_topics [string range $tail [string length get_topic_] end] |
||||
} |
||||
return $about_topics |
||||
} |
||||
proc default_topics {} {return [list Description outline *]} |
||||
|
||||
# ------------------------------------------------------------- |
||||
# get_topic_ functions add more to auto-include in about topics |
||||
# ------------------------------------------------------------- |
||||
proc get_topic_Description {} { |
||||
punk::args::lib::tstr [string trim { |
||||
punk pipeline features |
||||
} \n] |
||||
} |
||||
proc get_topic_License {} { |
||||
return "MIT" |
||||
} |
||||
proc get_topic_Version {} { |
||||
return $::punk::pipe::version |
||||
} |
||||
proc get_topic_Contributors {} { |
||||
set authors {{Julian Noble <julian@precisium.com.au>}} |
||||
set contributors "" |
||||
foreach a $authors { |
||||
append contributors $a \n |
||||
} |
||||
if {[string index $contributors end] eq "\n"} { |
||||
set contributors [string range $contributors 0 end-1] |
||||
} |
||||
return $contributors |
||||
} |
||||
proc get_topic_outline {} { |
||||
punk::args::lib::tstr -return string { |
||||
todo.. |
||||
} |
||||
} |
||||
# ------------------------------------------------------------- |
||||
} |
||||
|
||||
# we re-use the argument definition from punk::args::standard_about and override some items |
||||
set overrides [dict create] |
||||
dict set overrides @id -id "::punk::pipe::about" |
||||
dict set overrides @cmd -name "punk::pipe::about" |
||||
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||
About punk::pipe |
||||
}] \n] |
||||
dict set overrides topic -choices [list {*}[punk::pipe::argdoc::about_topics] *] |
||||
dict set overrides topic -choicerestricted 1 |
||||
dict set overrides topic -default [punk::pipe::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict |
||||
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
||||
lappend PUNKARGS [list $newdef] |
||||
proc about {args} { |
||||
package require punk::args |
||||
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on |
||||
set argd [punk::args::parse $args withid ::punk::pipe::about] |
||||
lassign [dict values $argd] _leaders opts values _received |
||||
punk::args::package::standard_about -package_about_namespace ::punk::pipe::argdoc {*}$opts {*}[dict get $values topic] |
||||
} |
||||
} |
||||
# end of sample 'about' function |
||||
# == === === === === === === === === === === === === === === |
||||
|
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::punk::pipe |
||||
} |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::pipe [tcl::namespace::eval punk::pipe { |
||||
variable pkg punk::pipe |
||||
variable version |
||||
set version 1.0 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in new issue