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
@ -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