You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
568 lines
18 KiB
568 lines
18 KiB
# -*- 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] |
|
|
|
|