123 changed files with 18437 additions and 5517 deletions
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,35 @@
|
||||
package require tcltest |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
variable common { |
||||
set result "" |
||||
} |
||||
|
||||
test renderline_basic_noansi {basic renderline calls with no ansi in underlay or overlay}\ |
||||
-setup $common -body { |
||||
set undertext "abcdefghij" |
||||
|
||||
#there must be no ansi codes in the output (e.g no resets introduced by renderline)) |
||||
|
||||
set editedline [overtype::renderline -insert_mode 0 $undertext ABCDE] |
||||
#set lineview [ansistring VIEW $editedline] |
||||
lappend result $editedline |
||||
|
||||
set editedline [overtype::renderline -insert_mode 1 $undertext ABCDE] |
||||
lappend result $editedline |
||||
|
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
ABCDEfghij ABCDEabcde |
||||
] |
||||
|
||||
#todo - test |
||||
#P% overtype::left -transparent 1 [textblock::block 10 2 -] " [a+ underline yellow].\n [a+ underline yellow]yyy" |
||||
#- --.------- |
||||
#- --yyy----- |
||||
#we expect the dot to be yellow and underlined and the yyy to be yellow and underlined - but not the dashes. |
||||
|
||||
} |
||||
@ -0,0 +1,139 @@
|
||||
# -*- 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 test::overtype 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license MIT |
||||
# @@ Meta End |
||||
|
||||
package require Tcl 8.6- |
||||
|
||||
tcl::namespace::eval test::overtype { |
||||
variable PUNKARGS |
||||
variable pkg test::overtype |
||||
variable version |
||||
set version 999999.0a1.0 |
||||
|
||||
package require packagetest |
||||
packagetest::makeAPI test::overtype $version overtype; #will package provide test::overtype $version |
||||
package forget overtype |
||||
package require overtype |
||||
} |
||||
|
||||
|
||||
# == === === === === === === === === === === === === === === |
||||
# Sample 'about' function with punk::args documentation |
||||
# == === === === === === === === === === === === === === === |
||||
tcl::namespace::eval test::overtype { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
variable PUNKARGS |
||||
variable PUNKARGS_aliases |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id "(package)test::overtype" |
||||
@package -name "test::overtype" -help\ |
||||
"Test suites for overtype module" |
||||
}] |
||||
|
||||
namespace eval argdoc { |
||||
#namespace for custom argument documentation |
||||
proc package_name {} { |
||||
return test::overtype |
||||
} |
||||
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 test::overtype |
||||
test suite for overtype module |
||||
} \n] |
||||
} |
||||
proc get_topic_License {} { |
||||
return "MIT" |
||||
} |
||||
proc get_topic_Version {} { |
||||
return "$::test::overtype::version" |
||||
} |
||||
proc get_topic_Contributors {} { |
||||
set authors {{<julian@precisium.com> Julian Noble}} |
||||
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 "::test::overtype::about" |
||||
dict set overrides @cmd -name "test::overtype::about" |
||||
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||
About test::overtype module |
||||
}] \n] |
||||
dict set overrides topic -choices [list {*}[test::overtype::argdoc::about_topics] *] |
||||
dict set overrides topic -choicerestricted 1 |
||||
dict set overrides topic -default [test::overtype::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 ::test::overtype::about] |
||||
lassign [dict values $argd] _leaders opts values _received |
||||
punk::args::package::standard_about -package_about_namespace ::test::overtype::argdoc {*}$opts {*}[dict get $values topic] |
||||
} |
||||
} |
||||
# end of sample 'about' function |
||||
# == === === === === === === === === === === === === === === |
||||
|
||||
# ----------------------------------------------------------------------------- |
||||
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked |
||||
# ----------------------------------------------------------------------------- |
||||
# variable PUNKARGS |
||||
# variable PUNKARGS_aliases |
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::test::overtype |
||||
} |
||||
# ----------------------------------------------------------------------------- |
||||
|
||||
package provide test::overtype [tcl::namespace::eval test::overtype { |
||||
variable pkg test::overtype |
||||
variable version |
||||
set version 999999.0a1.0 |
||||
}] |
||||
## Ready |
||||
return |
||||
@ -0,0 +1,3 @@
|
||||
1.7.4 |
||||
#First line must be a tcl package version number |
||||
#all other lines are ignored. |
||||
@ -1,80 +1,80 @@
|
||||
package require tcltest |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
variable common { |
||||
set result "" |
||||
} |
||||
|
||||
test ansistrip_basic_sgr_strip {test ansistrip on basic SGR colour code and reset}\ |
||||
-setup $common -body { |
||||
set a "\x1b\[31mxxx\x1b\[myyy" ;# set a [a+ red]xxx[a]yyy |
||||
lappend result [punk::ansi::ansistrip $a] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
xxxyyy |
||||
] |
||||
|
||||
test ansistrip_nonansi_escape {test ansistrip on non-ansi ESC}\ |
||||
-setup $common -body { |
||||
set a \x1bxxx ;#not an SGR or other known ansi sequence - should pass through |
||||
set b [punk::ansi::ansistrip $a] |
||||
lappend result [string equal $a $b] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
1 |
||||
] |
||||
|
||||
test ansistrip_movement {test ansistrip on ANSI move}\ |
||||
-setup $common -body { |
||||
set a X\x1b\[2\;2HY ;#not an SGR or other known ansi sequence - should pass through |
||||
#equivalent to : set a X[move 2 2]Y |
||||
lappend result [punk::ansi::ansistrip $a] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
XY |
||||
] |
||||
|
||||
test ansistrip_privacymessage_7bit {test ansistrip on a 7bit privacymessage strips entire pm}\ |
||||
-setup $common -body { |
||||
#regardless of whether various terminals display the PM contents or not - this is required to be stripped here. |
||||
set a "7bit secret \x1b^UN\x1b\\safe" |
||||
#equivalent to : set a X[move 2 2]Y |
||||
lappend result [punk::ansi::ansistrip $a] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
"7bit secret safe" |
||||
] |
||||
test ansistrip_privacymessage_8bit {test ansistrip on a 8bit privacymessage strips entire pm}\ |
||||
-setup $common -body { |
||||
#regardless of whether various terminals display the PM contents or not - this is required to be stripped here. |
||||
set a "8bit secret \x9eUN\x9csafe" |
||||
#equivalent to : set a X[move 2 2]Y |
||||
lappend result [punk::ansi::ansistrip $a] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
"8bit secret safe" |
||||
] |
||||
|
||||
test ansistrip_converts_vt100_gx {test ansistrip converts vt100 graphical symbols to unicode equivalent}\ |
||||
-setup $common -body { |
||||
set a "\x1b(0|\x1b(B" ;#equivalent [punk::ansi::g0 |] |
||||
lappend result [punk::ansi::ansistrip $a] ;#unicode not-equal symbol \u2260 |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
\u2260 |
||||
] |
||||
|
||||
package require tcltest |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
variable common { |
||||
set result "" |
||||
} |
||||
|
||||
test ansistrip_basic_sgr_strip {test ansistrip on basic SGR colour code and reset}\ |
||||
-setup $common -body { |
||||
set a "\x1b\[31mxxx\x1b\[myyy" ;# set a [a+ red]xxx[a]yyy |
||||
lappend result [punk::ansi::ansistrip $a] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
xxxyyy |
||||
] |
||||
|
||||
test ansistrip_nonansi_escape {test ansistrip on non-ansi ESC}\ |
||||
-setup $common -body { |
||||
set a \x1bxxx ;#not an SGR or other known ansi sequence - should pass through |
||||
set b [punk::ansi::ansistrip $a] |
||||
lappend result [string equal $a $b] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
1 |
||||
] |
||||
|
||||
test ansistrip_movement {test ansistrip on ANSI move}\ |
||||
-setup $common -body { |
||||
set a X\x1b\[2\;2HY ;#not an SGR or other known ansi sequence - should pass through |
||||
#equivalent to : set a X[move 2 2]Y |
||||
lappend result [punk::ansi::ansistrip $a] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
XY |
||||
] |
||||
|
||||
test ansistrip_privacymessage_7bit {test ansistrip on a 7bit privacymessage strips entire pm}\ |
||||
-setup $common -body { |
||||
#regardless of whether various terminals display the PM contents or not - this is required to be stripped here. |
||||
set a "7bit secret \x1b^UN\x1b\\safe" |
||||
#equivalent to : set a X[move 2 2]Y |
||||
lappend result [punk::ansi::ansistrip $a] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
"7bit secret safe" |
||||
] |
||||
test ansistrip_privacymessage_8bit {test ansistrip on a 8bit privacymessage strips entire pm}\ |
||||
-setup $common -body { |
||||
#regardless of whether various terminals display the PM contents or not - this is required to be stripped here. |
||||
set a "8bit secret \x9eUN\x9csafe" |
||||
#equivalent to : set a X[move 2 2]Y |
||||
lappend result [punk::ansi::ansistrip $a] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
"8bit secret safe" |
||||
] |
||||
|
||||
test ansistrip_converts_vt100_gx {test ansistrip converts vt100 graphical symbols to unicode equivalent}\ |
||||
-setup $common -body { |
||||
set a "\x1b(0|\x1b(B" ;#equivalent [punk::ansi::g0 |] |
||||
lappend result [punk::ansi::ansistrip $a] ;#unicode not-equal symbol \u2260 |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
\u2260 |
||||
] |
||||
|
||||
} |
||||
File diff suppressed because it is too large
Load Diff
@ -1,195 +1,195 @@
|
||||
package require tcltest |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
variable common { |
||||
set result "" |
||||
} |
||||
|
||||
|
||||
test choices_typeignored_when_choice_in_list {Test that -type is not validated for a value that matches a choice}\ |
||||
-setup $common -body { |
||||
#1 abbreviated choice |
||||
set argd [punk::args::parse {li} withdef @values {frametype -type dict -choices {heavy light arc}}] |
||||
lappend result [dict get $argd values] |
||||
|
||||
#2 exact match for a choice |
||||
set argd [punk::args::parse {light} withdef @values {frametype -type dict -choices {heavy light arc}}] |
||||
lappend result [dict get $argd values] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{frametype light}\ |
||||
{frametype light}\ |
||||
] |
||||
|
||||
test choices_type_validation_choicerestricted1 {Test that -type is validated for value outside of choicelist based on -choicerestricted}\ |
||||
-setup $common -body { |
||||
|
||||
set argd [punk::args::parse {11} withdef @values {frametype -type int -choicerestricted 0 -choices {heavy light arc}}] |
||||
lappend result [dict get $argd values] |
||||
|
||||
if {[catch { |
||||
punk::args::parse {z} withdef @values {frametype -type int -choicerestricted 0 -choices {heavy light arc}} |
||||
}]} { |
||||
lappend result "ok_got_expected_error1" |
||||
} else { |
||||
lappend result "missing_required_error_when_type_mismatch_for_choice_outside_list" |
||||
} |
||||
|
||||
#when -choicerestricted - value matching -type still shouldn't pass |
||||
if {[catch { |
||||
set argd [punk::args::parse {11} withdef @values {frametype -type int -choicerestricted 1 -choices {heavy light arc}}] |
||||
}]} { |
||||
lappend result "ok_got_expected_error2" |
||||
} else { |
||||
lappend result "missing_required_error_when_choicerestricted_and_choice_outside_list" |
||||
} |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{frametype 11}\ |
||||
ok_got_expected_error1\ |
||||
ok_got_expected_error2\ |
||||
] |
||||
|
||||
test choices_type_validation_choicerestricted2 {Test that -type dict is validated for value outside of choicelist based on -choicerestricted}\ |
||||
-setup $common -body { |
||||
#same as choices_type_validation_choicrestricted1 - but with a more complex type 'dict' - tests list protection is correct |
||||
set argd [punk::args::parse {{hl -}} withdef @values {frametype -type dict -choicerestricted 0 -choices {heavy light arc}}] |
||||
lappend result [dict get $argd values] |
||||
|
||||
if {[catch { |
||||
punk::args::parse {z} withdef @values {frametype -type dict -choicerestricted 0 -choices {heavy light arc}} |
||||
}]} { |
||||
lappend result "ok_got_expected_error1" |
||||
} else { |
||||
lappend result "missing_required_error_when_type_mismatch_for_choice_outside_list" |
||||
} |
||||
|
||||
#when -choicerestricted - value matching -type dict still shouldn't pass |
||||
if {[catch { |
||||
set argd [punk::args::parse {{hl -}} withdef @values {frametype -type dict -choicerestricted 1 -choices {heavy light arc}}] |
||||
}]} { |
||||
lappend result "ok_got_expected_error2" |
||||
} else { |
||||
lappend result "missing_required_error_when_choicerestricted_and_choice_outside_list" |
||||
} |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{frametype {hl -}}\ |
||||
ok_got_expected_error1\ |
||||
ok_got_expected_error2\ |
||||
] |
||||
|
||||
test choice_multiple_with_choiceprefix {test -choices with both -multiple and -choiceprefix}\ |
||||
-setup $common -body { |
||||
#test with full value choices. |
||||
set argd [punk::args::parse {license description} withdef @values {topic -choices {license contributors description} -choiceprefix 1 -multiple 1 }] |
||||
lappend result [dict get $argd values] |
||||
|
||||
#test with prefixes of choice. |
||||
set argd [punk::args::parse {lic desc} withdef @values {topic -choices {license contributors description} -choiceprefix 1 -multiple 1 }] |
||||
lappend result [dict get $argd values] |
||||
|
||||
#test with mixes of full value and prefix of choice. |
||||
set argd [punk::args::parse {license desc} withdef @values {topic -choices {license contributors description} -choiceprefix 1 -multiple 1 }] |
||||
lappend result [dict get $argd values] |
||||
|
||||
set argd [punk::args::parse {desc license} withdef @values {topic -choices {license contributors description} -choiceprefix 1 -multiple 1 }] |
||||
lappend result [dict get $argd values] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{topic {license description}}\ |
||||
{topic {license description}}\ |
||||
{topic {license description}}\ |
||||
{topic {description license}}\ |
||||
] |
||||
#todo -nocase tests |
||||
|
||||
test choice_multiple_multiple {test -choices with both -multiple and -choicemultiple}\ |
||||
-setup $common -body { |
||||
set argd [punk::args::parse {a {c a} {a b c}} withdef @values {X -type string -choices {aa bb cc} -multiple 1 -choicemultiple {1 3} -optional 1}] |
||||
lappend result [dict get $argd values] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{X {aa {cc aa} {aa bb cc}}} |
||||
] |
||||
# -choicemultiple allows duplicates in result by default (default for -choicemultipleunique 0) |
||||
|
||||
test choicemultiple_list {test -choices with both -multiple and -choicemultiple}\ |
||||
-setup $common -body { |
||||
set argd [punk::args::parse {{read write w}} withdef @values {mode -type list -choices {read write} -choicemultiple {1 -1}}] |
||||
lappend result [dict get $argd values] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{mode {read write write}} |
||||
] |
||||
|
||||
test choice_multielement_clause {test -choice with a clause-length greater than 1}\ |
||||
-setup $common -body { |
||||
#The same -choices list always applies to each member of -type - which isn't always ideal for a multi-element clause |
||||
#for a clause where each element has a different choiceset - we would need to introduce a more complex -typechoices option |
||||
#(or use a -parsekey mechanism on leaders/values to group them) |
||||
|
||||
#test all combinations of prefix and complete for 2 entries |
||||
set argd [punk::args::parse {light heavy} withdef @values {leftright -type {any any} -choices {light heavy} -choicerestricted 1}] |
||||
lappend result [dict get $argd values] |
||||
set argd [punk::args::parse {li heavy} withdef @values {leftright -type {any any} -choices {light heavy} -choicerestricted 1}] |
||||
lappend result [dict get $argd values] |
||||
set argd [punk::args::parse {li he} withdef @values {leftright -type {any any} -choices {light heavy} -choicerestricted 1}] |
||||
lappend result [dict get $argd values] |
||||
set argd [punk::args::parse {light he} withdef @values {leftright -type {any any} -choices {light heavy} -choicerestricted 1}] |
||||
lappend result [dict get $argd values] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{leftright {light heavy}}\ |
||||
{leftright {light heavy}}\ |
||||
{leftright {light heavy}}\ |
||||
{leftright {light heavy}}\ |
||||
] |
||||
|
||||
test choice_multielement_clause_unrestricted {test -choice with a clause-length greater than 1 and values outside of choicelist}\ |
||||
-setup $common -body { |
||||
#1 both values outside of -choices |
||||
set argd [punk::args::parse {11 x} withdef @values {leftright -type {int char} -choices {light heavy arc} -choicerestricted 0}] |
||||
lappend result [dict get $argd values] |
||||
# |
||||
set argd [punk::args::parse {11 arc} withdef @values {leftright -type {int char} -choices {light heavy arc} -choicerestricted 0}] |
||||
lappend result [dict get $argd values] |
||||
# |
||||
set argd [punk::args::parse {11 a} withdef @values {leftright -type {int char} -choices {light heavy arc} -choicerestricted 0}] |
||||
lappend result [dict get $argd values] |
||||
# |
||||
set argd [punk::args::parse {heavy x} withdef @values {leftright -type {int char} -choices {light heavy arc} -choicerestricted 0}] |
||||
lappend result [dict get $argd values] |
||||
# |
||||
set argd [punk::args::parse {h x} withdef @values {leftright -type {int char} -choices {light heavy arc} -choicerestricted 0}] |
||||
lappend result [dict get $argd values] |
||||
# |
||||
set argd [punk::args::parse {a h} withdef @values {leftright -type {int char} -choices {light heavy arc} -choicerestricted 0}] |
||||
lappend result [dict get $argd values] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{leftright {11 x}}\ |
||||
{leftright {11 arc}}\ |
||||
{leftright {11 arc}}\ |
||||
{leftright {heavy x}}\ |
||||
{leftright {heavy x}}\ |
||||
{leftright {arc heavy}}\ |
||||
] |
||||
package require tcltest |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
variable common { |
||||
set result "" |
||||
} |
||||
|
||||
|
||||
test choices_typeignored_when_choice_in_list {Test that -type is not validated for a value that matches a choice}\ |
||||
-setup $common -body { |
||||
#1 abbreviated choice |
||||
set argd [punk::args::parse {li} withdef @values {frametype -type dict -choices {heavy light arc}}] |
||||
lappend result [dict get $argd values] |
||||
|
||||
#2 exact match for a choice |
||||
set argd [punk::args::parse {light} withdef @values {frametype -type dict -choices {heavy light arc}}] |
||||
lappend result [dict get $argd values] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{frametype light}\ |
||||
{frametype light}\ |
||||
] |
||||
|
||||
test choices_type_validation_choicerestricted1 {Test that -type is validated for value outside of choicelist based on -choicerestricted}\ |
||||
-setup $common -body { |
||||
|
||||
set argd [punk::args::parse {11} withdef @values {frametype -type int -choicerestricted 0 -choices {heavy light arc}}] |
||||
lappend result [dict get $argd values] |
||||
|
||||
if {[catch { |
||||
punk::args::parse {z} withdef @values {frametype -type int -choicerestricted 0 -choices {heavy light arc}} |
||||
}]} { |
||||
lappend result "ok_got_expected_error1" |
||||
} else { |
||||
lappend result "missing_required_error_when_type_mismatch_for_choice_outside_list" |
||||
} |
||||
|
||||
#when -choicerestricted - value matching -type still shouldn't pass |
||||
if {[catch { |
||||
set argd [punk::args::parse {11} withdef @values {frametype -type int -choicerestricted 1 -choices {heavy light arc}}] |
||||
}]} { |
||||
lappend result "ok_got_expected_error2" |
||||
} else { |
||||
lappend result "missing_required_error_when_choicerestricted_and_choice_outside_list" |
||||
} |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{frametype 11}\ |
||||
ok_got_expected_error1\ |
||||
ok_got_expected_error2\ |
||||
] |
||||
|
||||
test choices_type_validation_choicerestricted2 {Test that -type dict is validated for value outside of choicelist based on -choicerestricted}\ |
||||
-setup $common -body { |
||||
#same as choices_type_validation_choicrestricted1 - but with a more complex type 'dict' - tests list protection is correct |
||||
set argd [punk::args::parse {{hl -}} withdef @values {frametype -type dict -choicerestricted 0 -choices {heavy light arc}}] |
||||
lappend result [dict get $argd values] |
||||
|
||||
if {[catch { |
||||
punk::args::parse {z} withdef @values {frametype -type dict -choicerestricted 0 -choices {heavy light arc}} |
||||
}]} { |
||||
lappend result "ok_got_expected_error1" |
||||
} else { |
||||
lappend result "missing_required_error_when_type_mismatch_for_choice_outside_list" |
||||
} |
||||
|
||||
#when -choicerestricted - value matching -type dict still shouldn't pass |
||||
if {[catch { |
||||
set argd [punk::args::parse {{hl -}} withdef @values {frametype -type dict -choicerestricted 1 -choices {heavy light arc}}] |
||||
}]} { |
||||
lappend result "ok_got_expected_error2" |
||||
} else { |
||||
lappend result "missing_required_error_when_choicerestricted_and_choice_outside_list" |
||||
} |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{frametype {hl -}}\ |
||||
ok_got_expected_error1\ |
||||
ok_got_expected_error2\ |
||||
] |
||||
|
||||
test choice_multiple_with_choiceprefix {test -choices with both -multiple and -choiceprefix}\ |
||||
-setup $common -body { |
||||
#test with full value choices. |
||||
set argd [punk::args::parse {license description} withdef @values {topic -choices {license contributors description} -choiceprefix 1 -multiple 1 }] |
||||
lappend result [dict get $argd values] |
||||
|
||||
#test with prefixes of choice. |
||||
set argd [punk::args::parse {lic desc} withdef @values {topic -choices {license contributors description} -choiceprefix 1 -multiple 1 }] |
||||
lappend result [dict get $argd values] |
||||
|
||||
#test with mixes of full value and prefix of choice. |
||||
set argd [punk::args::parse {license desc} withdef @values {topic -choices {license contributors description} -choiceprefix 1 -multiple 1 }] |
||||
lappend result [dict get $argd values] |
||||
|
||||
set argd [punk::args::parse {desc license} withdef @values {topic -choices {license contributors description} -choiceprefix 1 -multiple 1 }] |
||||
lappend result [dict get $argd values] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{topic {license description}}\ |
||||
{topic {license description}}\ |
||||
{topic {license description}}\ |
||||
{topic {description license}}\ |
||||
] |
||||
#todo -nocase tests |
||||
|
||||
test choice_multiple_multiple {test -choices with both -multiple and -choicemultiple}\ |
||||
-setup $common -body { |
||||
set argd [punk::args::parse {a {c a} {a b c}} withdef @values {X -type string -choices {aa bb cc} -multiple 1 -choicemultiple {1 3} -optional 1}] |
||||
lappend result [dict get $argd values] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{X {aa {cc aa} {aa bb cc}}} |
||||
] |
||||
# -choicemultiple allows duplicates in result by default (default for -choicemultipleunique 0) |
||||
|
||||
test choicemultiple_list {test -choices with both -multiple and -choicemultiple}\ |
||||
-setup $common -body { |
||||
set argd [punk::args::parse {{read write w}} withdef @values {mode -type list -choices {read write} -choicemultiple {1 -1}}] |
||||
lappend result [dict get $argd values] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{mode {read write write}} |
||||
] |
||||
|
||||
test choice_multielement_clause {test -choice with a clause-length greater than 1}\ |
||||
-setup $common -body { |
||||
#The same -choices list always applies to each member of -type - which isn't always ideal for a multi-element clause |
||||
#for a clause where each element has a different choiceset - we would need to introduce a more complex -typechoices option |
||||
#(or use a -parsekey mechanism on leaders/values to group them) |
||||
|
||||
#test all combinations of prefix and complete for 2 entries |
||||
set argd [punk::args::parse {light heavy} withdef @values {leftright -type {any any} -choices {light heavy} -choicerestricted 1}] |
||||
lappend result [dict get $argd values] |
||||
set argd [punk::args::parse {li heavy} withdef @values {leftright -type {any any} -choices {light heavy} -choicerestricted 1}] |
||||
lappend result [dict get $argd values] |
||||
set argd [punk::args::parse {li he} withdef @values {leftright -type {any any} -choices {light heavy} -choicerestricted 1}] |
||||
lappend result [dict get $argd values] |
||||
set argd [punk::args::parse {light he} withdef @values {leftright -type {any any} -choices {light heavy} -choicerestricted 1}] |
||||
lappend result [dict get $argd values] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{leftright {light heavy}}\ |
||||
{leftright {light heavy}}\ |
||||
{leftright {light heavy}}\ |
||||
{leftright {light heavy}}\ |
||||
] |
||||
|
||||
test choice_multielement_clause_unrestricted {test -choice with a clause-length greater than 1 and values outside of choicelist}\ |
||||
-setup $common -body { |
||||
#1 both values outside of -choices |
||||
set argd [punk::args::parse {11 x} withdef @values {leftright -type {int char} -choices {light heavy arc} -choicerestricted 0}] |
||||
lappend result [dict get $argd values] |
||||
# |
||||
set argd [punk::args::parse {11 arc} withdef @values {leftright -type {int char} -choices {light heavy arc} -choicerestricted 0}] |
||||
lappend result [dict get $argd values] |
||||
# |
||||
set argd [punk::args::parse {11 a} withdef @values {leftright -type {int char} -choices {light heavy arc} -choicerestricted 0}] |
||||
lappend result [dict get $argd values] |
||||
# |
||||
set argd [punk::args::parse {heavy x} withdef @values {leftright -type {int char} -choices {light heavy arc} -choicerestricted 0}] |
||||
lappend result [dict get $argd values] |
||||
# |
||||
set argd [punk::args::parse {h x} withdef @values {leftright -type {int char} -choices {light heavy arc} -choicerestricted 0}] |
||||
lappend result [dict get $argd values] |
||||
# |
||||
set argd [punk::args::parse {a h} withdef @values {leftright -type {int char} -choices {light heavy arc} -choicerestricted 0}] |
||||
lappend result [dict get $argd values] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{leftright {11 x}}\ |
||||
{leftright {11 arc}}\ |
||||
{leftright {11 arc}}\ |
||||
{leftright {heavy x}}\ |
||||
{leftright {heavy x}}\ |
||||
{leftright {arc heavy}}\ |
||||
] |
||||
} |
||||
@ -1,128 +1,128 @@
|
||||
package require tcltest |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
variable common { |
||||
set result "" |
||||
} |
||||
|
||||
test define_tstr_template1 {Test basic tstr substitution finds vars in namespace in which define was called}\ |
||||
-setup $common -body { |
||||
namespace eval whatever { |
||||
set plus +++ |
||||
set minus --- |
||||
|
||||
punk::args::define { |
||||
@id -id ::testspace::test1 |
||||
@values |
||||
param -type string -default "${$plus}XXX${$minus}YYY" |
||||
} |
||||
} |
||||
|
||||
set argd [punk::args::parse {} withid ::testspace::test1] |
||||
set vals [dict get $argd values] |
||||
lappend result [dict get $vals param] |
||||
}\ |
||||
-cleanup { |
||||
namespace delete ::testspace::whatever |
||||
punk::args::undefine ::testspace::test1 |
||||
}\ |
||||
-result [list\ |
||||
+++XXX---YYY |
||||
] |
||||
|
||||
test define_tstr_template2 {Test basic tstr substitution when @dynamic}\ |
||||
-setup $common -body { |
||||
namespace eval whatever { |
||||
set plus +++ |
||||
set minus --- |
||||
|
||||
punk::args::define { |
||||
@dynamic |
||||
@id -id ::testspace::test2 |
||||
@values |
||||
param -type string -default "${$plus}XXX${$minus}YYY" |
||||
} |
||||
} |
||||
|
||||
set argd [punk::args::parse {} withid ::testspace::test2] |
||||
puts ">>>>define_tstr_template2 argd:$argd" |
||||
set vals [dict get $argd values] |
||||
lappend result [dict get $vals param] |
||||
}\ |
||||
-cleanup { |
||||
namespace delete ::testspace::whatever |
||||
punk::args::undefine ::testspace::test2 |
||||
}\ |
||||
-result [list\ |
||||
+++XXX---YYY |
||||
] |
||||
|
||||
test define_tstr_template3 {Test double tstr substitution when @dynamic}\ |
||||
-setup $common -body { |
||||
variable test_list |
||||
set test_list {A B C} |
||||
proc ::testspace::get_list {} { |
||||
variable test_list |
||||
return $test_list |
||||
} |
||||
namespace eval whatever { |
||||
set plus +++ |
||||
set minus --- |
||||
set DYN_LIST {${[::testspace::get_list]}} |
||||
set DYN_CLOCKSECONDS {${[clock seconds]}} |
||||
|
||||
punk::args::define { |
||||
@dynamic |
||||
@id -id ::testspace::test2 |
||||
@values |
||||
param1 -type string -default "${$plus}XXX${$minus}YYY" |
||||
param2 -type list -default "${$DYN_LIST}" |
||||
param3 -type string -default "${[clock seconds]}" |
||||
param4 -type string -default "${$DYN_CLOCKSECONDS}" |
||||
} |
||||
} |
||||
|
||||
set argd [punk::args::parse {} withid ::testspace::test2] |
||||
set vals [dict get $argd values] |
||||
lappend result [dict get $vals param1] |
||||
lappend result [dict get $vals param2] |
||||
set c1_at_define [dict get $vals param3] |
||||
set c1_at_resolve [dict get $vals param4] |
||||
|
||||
#update test_list to ensure parse is actually dynamic |
||||
set ::testspace::test_list {X Y Z} |
||||
#update plus - should not affect output as it is resolved at define time |
||||
set ::testspace::whatever::plus "new+" |
||||
#unset minus - should not cause error |
||||
unset ::testspace::whatever::minus |
||||
after 1100 ;#ensure more than 1 sec apart |
||||
|
||||
|
||||
set argd [punk::args::parse {} withid ::testspace::test2] |
||||
set vals [dict get $argd values] |
||||
lappend result [dict get $vals param1] |
||||
lappend result [dict get $vals param2] |
||||
set c2_at_define [dict get $vals param3] |
||||
set c2_at_resolve [dict get $vals param4] |
||||
|
||||
if {$c1_at_define == $c2_at_define} { |
||||
lappend result "OK_define_time_var_match" |
||||
} else { |
||||
lappend result "UNEXPECTED_define_time_var_mismatch" |
||||
} |
||||
if {$c1_at_resolve < $c2_at_resolve} { |
||||
lappend result "OK_resolve_time_2_greater" |
||||
} else { |
||||
lappend result "UNEXPECTED_resolve_time_2_not_greater" |
||||
} |
||||
|
||||
}\ |
||||
-cleanup { |
||||
namespace delete ::testspace::whatever |
||||
punk::args::undefine ::testspace::test2 |
||||
}\ |
||||
-result [list\ |
||||
+++XXX---YYY {A B C} +++XXX---YYY {X Y Z} OK_define_time_var_match OK_resolve_time_2_greater |
||||
] |
||||
package require tcltest |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
variable common { |
||||
set result "" |
||||
} |
||||
|
||||
test define_tstr_template1 {Test basic tstr substitution finds vars in namespace in which define was called}\ |
||||
-setup $common -body { |
||||
namespace eval whatever { |
||||
set plus +++ |
||||
set minus --- |
||||
|
||||
punk::args::define { |
||||
@id -id ::testspace::test1 |
||||
@values |
||||
param -type string -default "${$plus}XXX${$minus}YYY" |
||||
} |
||||
} |
||||
|
||||
set argd [punk::args::parse {} withid ::testspace::test1] |
||||
set vals [dict get $argd values] |
||||
lappend result [dict get $vals param] |
||||
}\ |
||||
-cleanup { |
||||
namespace delete ::testspace::whatever |
||||
punk::args::undefine ::testspace::test1 |
||||
}\ |
||||
-result [list\ |
||||
+++XXX---YYY |
||||
] |
||||
|
||||
test define_tstr_template2 {Test basic tstr substitution when @dynamic}\ |
||||
-setup $common -body { |
||||
namespace eval whatever { |
||||
set plus +++ |
||||
set minus --- |
||||
|
||||
punk::args::define { |
||||
@dynamic |
||||
@id -id ::testspace::test2 |
||||
@values |
||||
param -type string -default "${$plus}XXX${$minus}YYY" |
||||
} |
||||
} |
||||
|
||||
set argd [punk::args::parse {} withid ::testspace::test2] |
||||
puts ">>>>define_tstr_template2 argd:$argd" |
||||
set vals [dict get $argd values] |
||||
lappend result [dict get $vals param] |
||||
}\ |
||||
-cleanup { |
||||
namespace delete ::testspace::whatever |
||||
punk::args::undefine ::testspace::test2 |
||||
}\ |
||||
-result [list\ |
||||
+++XXX---YYY |
||||
] |
||||
|
||||
test define_tstr_template3 {Test double tstr substitution when @dynamic}\ |
||||
-setup $common -body { |
||||
variable test_list |
||||
set test_list {A B C} |
||||
proc ::testspace::get_list {} { |
||||
variable test_list |
||||
return $test_list |
||||
} |
||||
namespace eval whatever { |
||||
set plus +++ |
||||
set minus --- |
||||
set DYN_LIST {${[::testspace::get_list]}} |
||||
set DYN_CLOCKSECONDS {${[clock seconds]}} |
||||
|
||||
punk::args::define { |
||||
@dynamic |
||||
@id -id ::testspace::test2 |
||||
@values |
||||
param1 -type string -default "${$plus}XXX${$minus}YYY" |
||||
param2 -type list -default "${$DYN_LIST}" |
||||
param3 -type string -default "${[clock seconds]}" |
||||
param4 -type string -default "${$DYN_CLOCKSECONDS}" |
||||
} |
||||
} |
||||
|
||||
set argd [punk::args::parse {} withid ::testspace::test2] |
||||
set vals [dict get $argd values] |
||||
lappend result [dict get $vals param1] |
||||
lappend result [dict get $vals param2] |
||||
set c1_at_define [dict get $vals param3] |
||||
set c1_at_resolve [dict get $vals param4] |
||||
|
||||
#update test_list to ensure parse is actually dynamic |
||||
set ::testspace::test_list {X Y Z} |
||||
#update plus - should not affect output as it is resolved at define time |
||||
set ::testspace::whatever::plus "new+" |
||||
#unset minus - should not cause error |
||||
unset ::testspace::whatever::minus |
||||
after 1100 ;#ensure more than 1 sec apart |
||||
|
||||
|
||||
set argd [punk::args::parse {} withid ::testspace::test2] |
||||
set vals [dict get $argd values] |
||||
lappend result [dict get $vals param1] |
||||
lappend result [dict get $vals param2] |
||||
set c2_at_define [dict get $vals param3] |
||||
set c2_at_resolve [dict get $vals param4] |
||||
|
||||
if {$c1_at_define == $c2_at_define} { |
||||
lappend result "OK_define_time_var_match" |
||||
} else { |
||||
lappend result "UNEXPECTED_define_time_var_mismatch" |
||||
} |
||||
if {$c1_at_resolve < $c2_at_resolve} { |
||||
lappend result "OK_resolve_time_2_greater" |
||||
} else { |
||||
lappend result "UNEXPECTED_resolve_time_2_not_greater" |
||||
} |
||||
|
||||
}\ |
||||
-cleanup { |
||||
namespace delete ::testspace::whatever |
||||
punk::args::undefine ::testspace::test2 |
||||
}\ |
||||
-result [list\ |
||||
+++XXX---YYY {A B C} +++XXX---YYY {X Y Z} OK_define_time_var_match OK_resolve_time_2_greater |
||||
] |
||||
} |
||||
@ -1,225 +1,225 @@
|
||||
|
||||
package require tcltest |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
variable common { |
||||
set result "" |
||||
} |
||||
|
||||
#test mash opts aka "option clustering" aka "flag stacking" aka "option combining" aka "short flag bundling" etc. |
||||
|
||||
test mashopts_default {Test basic combining of short options when -mash set as default for short flags on @opts directive}\ |
||||
-setup $common -body { |
||||
|
||||
#first test they work individually as normal |
||||
set argd [punk::args::parse {-a -b -c} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none}] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
#test all combined |
||||
set argd [punk::args::parse {-abc} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none}] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
#varying order of flags in mash should still work |
||||
set argd [punk::args::parse {-cab} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none}] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
#repeating flags in mash should still work and be treated as if they were repeated separately (ie -aa should be treated as if it were -a -a) |
||||
#in this case we have not configured any of the flags to be multiple, so the second occurrence of each flag should just override the first occurrence and have no effect |
||||
set argd [punk::args::parse {-caba} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none}] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
#order of flags in the result should be the same as the order of flags in the definition of the optionset, |
||||
#not the order in which they were supplied in the mash - this is because we want the result to be deterministic and not depend on the order in which the user happened to combine the flags in the mash |
||||
#the actual order should be reflected in the received list. |
||||
set argd [punk::args::parse {-caba} withdef {@opts -mash 1} {-c -type none} {-a -type none} {-b -type none}] |
||||
lappend result [dict get $argd opts] |
||||
#the received list should show the repeated -a even though it's not set for multiple. |
||||
lappend result [dict get $argd received] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{-a 1 -b 1 -c 1}\ |
||||
{-a 1 -b 1 -c 1}\ |
||||
{-a 1 -b 1 -c 1}\ |
||||
{-a 1 -b 1 -c 1}\ |
||||
{-c 1 -a 1 -b 1}\ |
||||
{-c 0 -a 1 -b 2 -a 3}\ |
||||
] |
||||
|
||||
test mashopts_default_with_multiple {Test combining of short options when -mash set as default for short flags on @opts directive and a flag is set to -multiple}\ |
||||
-setup $common -body { |
||||
|
||||
#first test they work individually as normal |
||||
set argd [punk::args::parse {-a -b -c} withdef {@opts -mash 1} {-a -type none} {-b -type none -multiple true} {-c -type none}] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
set argd [punk::args::parse {-cba} withdef {@opts -mash 1} {-a -type none} {-b -type none -multiple true} {-c -type none}] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
#test a repeated flag within the mash |
||||
set argd [punk::args::parse {-cbba} withdef {@opts -mash 1} {-a -type none} {-b -type none -multiple true} {-c -type none}] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
#test a repeated flag after the mash |
||||
set argd [punk::args::parse {-cba -b} withdef {@opts -mash 1} {-a -type none} {-b -type none -multiple true} {-c -type none}] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
#test a repeated flag before the mash |
||||
set argd [punk::args::parse {-b -cba} withdef {@opts -mash 1} {-a -type none} {-b -type none -multiple true} {-c -type none}] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
#test a repeated flag before and after the mash |
||||
set argd [punk::args::parse {-b -cba -b} withdef {@opts -mash 1} {-a -type none} {-b -type none -multiple true} {-c -type none}] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
#test a repeated flag before, within and after the mash |
||||
set argd [punk::args::parse {-b -cbab -b} withdef {@opts -mash 1} {-a -type none} {-b -type none -multiple true} {-c -type none}] |
||||
lappend result [dict get $argd opts] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{-a 1 -b 1 -c 1}\ |
||||
{-a 1 -b 1 -c 1}\ |
||||
{-a 1 -b {1 1} -c 1}\ |
||||
{-a 1 -b {1 1} -c 1}\ |
||||
{-a 1 -b {1 1} -c 1}\ |
||||
{-a 1 -b {1 1 1} -c 1}\ |
||||
{-a 1 -b {1 1 1 1} -c 1}\ |
||||
] |
||||
|
||||
test mashopts_default_with_typed_shortflag {Test combining of short options when -mash set as default for short flags on @opts directive and a shortopt accepts a value}\ |
||||
-setup $common -body { |
||||
|
||||
#test individually |
||||
set argd [punk::args::parse {-a -b -f fff -c} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none} {-f -type string}] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
#test with mash - the flag that accepts a value must be at the end of the mash. |
||||
set argd [punk::args::parse {-bacf fff} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none} {-f -type string}] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
#should error if the flag that accepts a value is not at the end of the mash, because that would be ambiguous - we would not know which flag the value belongs to |
||||
if {[catch {punk::args::parse {-bafc fff} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none} {-f -type string}} err]} { |
||||
lappend result "expected-error" |
||||
} else { |
||||
lappend result "missing-expected-error" |
||||
} |
||||
|
||||
#failing to provide a value for -f should raise an error. |
||||
if {[catch {punk::args::parse {-bacf} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none} {-f -type string}} err]} { |
||||
lappend result "expected-error" |
||||
} else { |
||||
lappend result "missing-expected-error" |
||||
} |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{-a 1 -b 1 -c 1 -f fff}\ |
||||
{-a 1 -b 1 -c 1 -f fff}\ |
||||
expected-error\ |
||||
expected-error\ |
||||
] |
||||
|
||||
test mashopts_default_with_other_flags {Test combining of short options when -mash set as default for short flags on @opts directive plus a longer value-accepting flag and a value}\ |
||||
-setup $common -body { |
||||
|
||||
#test individually |
||||
set argd [punk::args::parse {-a -b -f fff -c -cabinet ccc ttt} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none} {-f -type string} {-cabinet -type string} @values tail] |
||||
lappend result [dict get $argd opts] |
||||
lappend result [dict get $argd values] |
||||
|
||||
|
||||
#should error if the non-mash flag that accepts a value is supplied with a prefix shorter than the number of mash flags. |
||||
#(we don't calculate prefixes based on a possibly huge combination of mash flags, so we simply require prefixes for non-mash flags to be at least as long as the number of mash flags) |
||||
if {[catch {punk::args::parse {-bacf fff -cabi ccc ttt} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none} {-f -type string} {-cabinet -type string} @values tail} err]} { |
||||
lappend result "expected-error" |
||||
} else { |
||||
lappend result "missing-expected-error" |
||||
} |
||||
|
||||
#we have 4 mash flags here, so a unique prefix of cabinet that is 5 long should be accepted. |
||||
set argd [punk::args::parse {-cabf fff -c -cabin ccc ttt} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none} {-f -type string} {-cabinet -type string} @values {tail -multiple 1 -optional 1}] |
||||
lappend result [dict get $argd opts] |
||||
lappend result [dict get $argd values] |
||||
|
||||
#test it's not confused by a short prefix of cabinet that matches only mash flags. |
||||
#-cab should be processed as match flags - not a prefix of cabinet. |
||||
set argd [punk::args::parse {-cabf fff -c -cab ccc ttt} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none} {-f -type string} {-cabinet -type string} @values {tail -multiple 1 -optional 1}] |
||||
lappend result [dict get $argd opts] |
||||
lappend result [dict get $argd values] |
||||
|
||||
|
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{-a 1 -b 1 -c 1 -f fff -cabinet ccc}\ |
||||
{tail ttt}\ |
||||
expected-error\ |
||||
{-a 1 -b 1 -c 1 -f fff -cabinet ccc}\ |
||||
{tail ttt}\ |
||||
{-a 1 -b 1 -c 1 -f fff}\ |
||||
{tail {ccc ttt}}\ |
||||
] |
||||
|
||||
test mashopts_mix_default_and_explicit {Test combining of short options when -mash set both on @opts and directly}\ |
||||
-setup $common -body { |
||||
|
||||
#-c no longer allowed in mash |
||||
|
||||
set argd [punk::args::parse {-a -b -f fff -c -cabinet ccc ttt} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none -mash 0} {-f -type string} {-cabinet -type string} @values tail] |
||||
lappend result [dict get $argd opts] |
||||
lappend result [dict get $argd values] |
||||
|
||||
|
||||
set argd [punk::args::parse {-abf fff -c -cabinet ccc ttt} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none -mash 0} {-f -type string} {-cabinet -type string} @values tail] |
||||
lappend result [dict get $argd opts] |
||||
lappend result [dict get $argd values] |
||||
|
||||
#attempting to mash -c should raise an error. |
||||
if {[catch {punk::args::parse {-bacf fff -cabinet ccc ttt} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none -mash 0} {-f -type string} {-cabinet -type string} @values tail} err]} { |
||||
lappend result "expected-error" |
||||
} else { |
||||
lappend result "missing-expected-error" |
||||
} |
||||
|
||||
#test with only explicit -mash 1 on individual flags. |
||||
set argd [punk::args::parse {-abf fff -c -cabinet ccc ttt} withdef @opts {-a -type none -mash 1} {-b -type none -mash 1} {-c -type none} {-f -type string -mash 1} {-cabinet -type string} @values tail] |
||||
lappend result [dict get $argd opts] |
||||
lappend result [dict get $argd values] |
||||
|
||||
#attempting to explicitly apply -mash 1 to -cabinet should raise an error because -cabinet is not a short flag and we only allow -mash 1 to be applied to short flags. |
||||
#(default -mash 1 on @opts is different as it is automatically only propagated to short flags.) |
||||
if {[catch {punk::args::parse {-acbf fff -cabinet ccc ttt} withdef @opts {-a -type none -mash 1} {-b -type none -mash 1} {-c -type none} {-f -type string -mash 1} {-cabinet -type string -mash 1} @values tail} err]} { |
||||
lappend result "expected-error" |
||||
} else { |
||||
lappend result "missing-expected-error" |
||||
} |
||||
|
||||
|
||||
#-c should default to not being mashable, so attempting to mash it should raise an error. |
||||
if {[catch {punk::args::parse {-acbf fff -cabinet ccc ttt} withdef @opts {-a -type none -mash 1} {-b -type none -mash 1} {-c -type none} {-f -type string -mash 1} {-cabinet -type string} @values tail} err]} { |
||||
lappend result "expected-error" |
||||
} else { |
||||
lappend result "missing-expected-error" |
||||
} |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{-a 1 -b 1 -c 1 -f fff -cabinet ccc}\ |
||||
{tail ttt}\ |
||||
{-a 1 -b 1 -c 1 -f fff -cabinet ccc}\ |
||||
{tail ttt}\ |
||||
expected-error\ |
||||
{-a 1 -b 1 -c 1 -f fff -cabinet ccc}\ |
||||
{tail ttt}\ |
||||
expected-error\ |
||||
expected-error\ |
||||
] |
||||
|
||||
|
||||
package require tcltest |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
variable common { |
||||
set result "" |
||||
} |
||||
|
||||
#test mash opts aka "option clustering" aka "flag stacking" aka "option combining" aka "short flag bundling" etc. |
||||
|
||||
test mashopts_default {Test basic combining of short options when -mash set as default for short flags on @opts directive}\ |
||||
-setup $common -body { |
||||
|
||||
#first test they work individually as normal |
||||
set argd [punk::args::parse {-a -b -c} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none}] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
#test all combined |
||||
set argd [punk::args::parse {-abc} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none}] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
#varying order of flags in mash should still work |
||||
set argd [punk::args::parse {-cab} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none}] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
#repeating flags in mash should still work and be treated as if they were repeated separately (ie -aa should be treated as if it were -a -a) |
||||
#in this case we have not configured any of the flags to be multiple, so the second occurrence of each flag should just override the first occurrence and have no effect |
||||
set argd [punk::args::parse {-caba} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none}] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
#order of flags in the result should be the same as the order of flags in the definition of the optionset, |
||||
#not the order in which they were supplied in the mash - this is because we want the result to be deterministic and not depend on the order in which the user happened to combine the flags in the mash |
||||
#the actual order should be reflected in the received list. |
||||
set argd [punk::args::parse {-caba} withdef {@opts -mash 1} {-c -type none} {-a -type none} {-b -type none}] |
||||
lappend result [dict get $argd opts] |
||||
#the received list should show the repeated -a even though it's not set for multiple. |
||||
lappend result [dict get $argd received] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{-a 1 -b 1 -c 1}\ |
||||
{-a 1 -b 1 -c 1}\ |
||||
{-a 1 -b 1 -c 1}\ |
||||
{-a 1 -b 1 -c 1}\ |
||||
{-c 1 -a 1 -b 1}\ |
||||
{-c 0 -a 1 -b 2 -a 3}\ |
||||
] |
||||
|
||||
test mashopts_default_with_multiple {Test combining of short options when -mash set as default for short flags on @opts directive and a flag is set to -multiple}\ |
||||
-setup $common -body { |
||||
|
||||
#first test they work individually as normal |
||||
set argd [punk::args::parse {-a -b -c} withdef {@opts -mash 1} {-a -type none} {-b -type none -multiple true} {-c -type none}] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
set argd [punk::args::parse {-cba} withdef {@opts -mash 1} {-a -type none} {-b -type none -multiple true} {-c -type none}] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
#test a repeated flag within the mash |
||||
set argd [punk::args::parse {-cbba} withdef {@opts -mash 1} {-a -type none} {-b -type none -multiple true} {-c -type none}] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
#test a repeated flag after the mash |
||||
set argd [punk::args::parse {-cba -b} withdef {@opts -mash 1} {-a -type none} {-b -type none -multiple true} {-c -type none}] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
#test a repeated flag before the mash |
||||
set argd [punk::args::parse {-b -cba} withdef {@opts -mash 1} {-a -type none} {-b -type none -multiple true} {-c -type none}] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
#test a repeated flag before and after the mash |
||||
set argd [punk::args::parse {-b -cba -b} withdef {@opts -mash 1} {-a -type none} {-b -type none -multiple true} {-c -type none}] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
#test a repeated flag before, within and after the mash |
||||
set argd [punk::args::parse {-b -cbab -b} withdef {@opts -mash 1} {-a -type none} {-b -type none -multiple true} {-c -type none}] |
||||
lappend result [dict get $argd opts] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{-a 1 -b 1 -c 1}\ |
||||
{-a 1 -b 1 -c 1}\ |
||||
{-a 1 -b {1 1} -c 1}\ |
||||
{-a 1 -b {1 1} -c 1}\ |
||||
{-a 1 -b {1 1} -c 1}\ |
||||
{-a 1 -b {1 1 1} -c 1}\ |
||||
{-a 1 -b {1 1 1 1} -c 1}\ |
||||
] |
||||
|
||||
test mashopts_default_with_typed_shortflag {Test combining of short options when -mash set as default for short flags on @opts directive and a shortopt accepts a value}\ |
||||
-setup $common -body { |
||||
|
||||
#test individually |
||||
set argd [punk::args::parse {-a -b -f fff -c} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none} {-f -type string}] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
#test with mash - the flag that accepts a value must be at the end of the mash. |
||||
set argd [punk::args::parse {-bacf fff} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none} {-f -type string}] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
#should error if the flag that accepts a value is not at the end of the mash, because that would be ambiguous - we would not know which flag the value belongs to |
||||
if {[catch {punk::args::parse {-bafc fff} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none} {-f -type string}} err]} { |
||||
lappend result "expected-error" |
||||
} else { |
||||
lappend result "missing-expected-error" |
||||
} |
||||
|
||||
#failing to provide a value for -f should raise an error. |
||||
if {[catch {punk::args::parse {-bacf} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none} {-f -type string}} err]} { |
||||
lappend result "expected-error" |
||||
} else { |
||||
lappend result "missing-expected-error" |
||||
} |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{-a 1 -b 1 -c 1 -f fff}\ |
||||
{-a 1 -b 1 -c 1 -f fff}\ |
||||
expected-error\ |
||||
expected-error\ |
||||
] |
||||
|
||||
test mashopts_default_with_other_flags {Test combining of short options when -mash set as default for short flags on @opts directive plus a longer value-accepting flag and a value}\ |
||||
-setup $common -body { |
||||
|
||||
#test individually |
||||
set argd [punk::args::parse {-a -b -f fff -c -cabinet ccc ttt} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none} {-f -type string} {-cabinet -type string} @values tail] |
||||
lappend result [dict get $argd opts] |
||||
lappend result [dict get $argd values] |
||||
|
||||
|
||||
#should error if the non-mash flag that accepts a value is supplied with a prefix shorter than the number of mash flags. |
||||
#(we don't calculate prefixes based on a possibly huge combination of mash flags, so we simply require prefixes for non-mash flags to be at least as long as the number of mash flags) |
||||
if {[catch {punk::args::parse {-bacf fff -cabi ccc ttt} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none} {-f -type string} {-cabinet -type string} @values tail} err]} { |
||||
lappend result "expected-error" |
||||
} else { |
||||
lappend result "missing-expected-error" |
||||
} |
||||
|
||||
#we have 4 mash flags here, so a unique prefix of cabinet that is 5 long should be accepted. |
||||
set argd [punk::args::parse {-cabf fff -c -cabin ccc ttt} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none} {-f -type string} {-cabinet -type string} @values {tail -multiple 1 -optional 1}] |
||||
lappend result [dict get $argd opts] |
||||
lappend result [dict get $argd values] |
||||
|
||||
#test it's not confused by a short prefix of cabinet that matches only mash flags. |
||||
#-cab should be processed as match flags - not a prefix of cabinet. |
||||
set argd [punk::args::parse {-cabf fff -c -cab ccc ttt} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none} {-f -type string} {-cabinet -type string} @values {tail -multiple 1 -optional 1}] |
||||
lappend result [dict get $argd opts] |
||||
lappend result [dict get $argd values] |
||||
|
||||
|
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{-a 1 -b 1 -c 1 -f fff -cabinet ccc}\ |
||||
{tail ttt}\ |
||||
expected-error\ |
||||
{-a 1 -b 1 -c 1 -f fff -cabinet ccc}\ |
||||
{tail ttt}\ |
||||
{-a 1 -b 1 -c 1 -f fff}\ |
||||
{tail {ccc ttt}}\ |
||||
] |
||||
|
||||
test mashopts_mix_default_and_explicit {Test combining of short options when -mash set both on @opts and directly}\ |
||||
-setup $common -body { |
||||
|
||||
#-c no longer allowed in mash |
||||
|
||||
set argd [punk::args::parse {-a -b -f fff -c -cabinet ccc ttt} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none -mash 0} {-f -type string} {-cabinet -type string} @values tail] |
||||
lappend result [dict get $argd opts] |
||||
lappend result [dict get $argd values] |
||||
|
||||
|
||||
set argd [punk::args::parse {-abf fff -c -cabinet ccc ttt} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none -mash 0} {-f -type string} {-cabinet -type string} @values tail] |
||||
lappend result [dict get $argd opts] |
||||
lappend result [dict get $argd values] |
||||
|
||||
#attempting to mash -c should raise an error. |
||||
if {[catch {punk::args::parse {-bacf fff -cabinet ccc ttt} withdef {@opts -mash 1} {-a -type none} {-b -type none} {-c -type none -mash 0} {-f -type string} {-cabinet -type string} @values tail} err]} { |
||||
lappend result "expected-error" |
||||
} else { |
||||
lappend result "missing-expected-error" |
||||
} |
||||
|
||||
#test with only explicit -mash 1 on individual flags. |
||||
set argd [punk::args::parse {-abf fff -c -cabinet ccc ttt} withdef @opts {-a -type none -mash 1} {-b -type none -mash 1} {-c -type none} {-f -type string -mash 1} {-cabinet -type string} @values tail] |
||||
lappend result [dict get $argd opts] |
||||
lappend result [dict get $argd values] |
||||
|
||||
#attempting to explicitly apply -mash 1 to -cabinet should raise an error because -cabinet is not a short flag and we only allow -mash 1 to be applied to short flags. |
||||
#(default -mash 1 on @opts is different as it is automatically only propagated to short flags.) |
||||
if {[catch {punk::args::parse {-acbf fff -cabinet ccc ttt} withdef @opts {-a -type none -mash 1} {-b -type none -mash 1} {-c -type none} {-f -type string -mash 1} {-cabinet -type string -mash 1} @values tail} err]} { |
||||
lappend result "expected-error" |
||||
} else { |
||||
lappend result "missing-expected-error" |
||||
} |
||||
|
||||
|
||||
#-c should default to not being mashable, so attempting to mash it should raise an error. |
||||
if {[catch {punk::args::parse {-acbf fff -cabinet ccc ttt} withdef @opts {-a -type none -mash 1} {-b -type none -mash 1} {-c -type none} {-f -type string -mash 1} {-cabinet -type string} @values tail} err]} { |
||||
lappend result "expected-error" |
||||
} else { |
||||
lappend result "missing-expected-error" |
||||
} |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{-a 1 -b 1 -c 1 -f fff -cabinet ccc}\ |
||||
{tail ttt}\ |
||||
{-a 1 -b 1 -c 1 -f fff -cabinet ccc}\ |
||||
{tail ttt}\ |
||||
expected-error\ |
||||
{-a 1 -b 1 -c 1 -f fff -cabinet ccc}\ |
||||
{tail ttt}\ |
||||
expected-error\ |
||||
expected-error\ |
||||
] |
||||
|
||||
} |
||||
@ -1,76 +1,76 @@
|
||||
|
||||
package require tcltest |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
variable common { |
||||
set result "" |
||||
} |
||||
|
||||
|
||||
test opts_longoptvalue {Test -alt|--longopt= can accept value as longopt}\ |
||||
-setup $common -body { |
||||
set argd [punk::args::parse {--filename=abc} withdef @opts {-f|--filename= -default spud -type string}] |
||||
lappend result [dict get $argd opts];#name by default should be last flag alternative (stripped of =) ie "--filename" |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{--filename abc}\ |
||||
] |
||||
|
||||
test opts_longoptvalue_alternative {Test -alt|--longopt= can accept value as spaced argument to given alternative}\ |
||||
-setup $common -body { |
||||
#test full name of alt flag |
||||
set argd [punk::args::parse {-fx xyz} withdef @opts {-fx|--filename= -default spud -type string}] |
||||
lappend result [dict get $argd opts] ;#name by default should be last flag alternative (stripped of =) ie "--filename" |
||||
#test prefixed version of flag |
||||
set argd [punk::args::parse {-f xyz} withdef @opts {-fx|--filename= -default spud -type string}] |
||||
lappend result [dict get $argd opts] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{--filename xyz}\ |
||||
{--filename xyz}\ |
||||
] |
||||
|
||||
test opts_longoptvalue_alternative_noninterference {Test -alt|--longopt= can accept longopt values as normal }\ |
||||
-setup $common -body { |
||||
#test full name of longopt |
||||
set argd [punk::args::parse {--filename=xyz} withdef @opts {-fx|--filename= -default spud -type string}] |
||||
lappend result [dict get $argd opts] ;#name by default should be last flag alternative (stripped of =) ie "--filename" |
||||
#test prefixed version of longopt |
||||
set argd [punk::args::parse {--file=xyz} withdef @opts {-fx|--filename= -default spud -type string}] |
||||
lappend result [dict get $argd opts] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{--filename xyz}\ |
||||
{--filename xyz}\ |
||||
] |
||||
|
||||
test opts_longoptvalue_choice {Test --longopt= works wiith -choices}\ |
||||
-setup $common -body { |
||||
#prefixed choice with and without prefixed flagname |
||||
set argd [punk::args::parse {--filename=x} withdef @opts {--filename= -default spud -type string -choices {abc xyz}}] |
||||
lappend result [dict get $argd opts] |
||||
set argd [punk::args::parse {--file=x} withdef @opts {--filename= -default spud -type string -choices {abc xyz}}] |
||||
lappend result [dict get $argd opts] |
||||
#unprefixed choice with and without prefixed flagname |
||||
set argd [punk::args::parse {--filename=xyz} withdef @opts {--filename= -default spud -type string -choices {abc xyz}}] |
||||
lappend result [dict get $argd opts] |
||||
set argd [punk::args::parse {--file=xyz} withdef @opts {--filename= -default spud -type string -choices {abc xyz}}] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{--filename xyz}\ |
||||
{--filename xyz}\ |
||||
{--filename xyz}\ |
||||
{--filename xyz}\ |
||||
] |
||||
|
||||
package require tcltest |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
variable common { |
||||
set result "" |
||||
} |
||||
|
||||
|
||||
test opts_longoptvalue {Test -alt|--longopt= can accept value as longopt}\ |
||||
-setup $common -body { |
||||
set argd [punk::args::parse {--filename=abc} withdef @opts {-f|--filename= -default spud -type string}] |
||||
lappend result [dict get $argd opts];#name by default should be last flag alternative (stripped of =) ie "--filename" |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{--filename abc}\ |
||||
] |
||||
|
||||
test opts_longoptvalue_alternative {Test -alt|--longopt= can accept value as spaced argument to given alternative}\ |
||||
-setup $common -body { |
||||
#test full name of alt flag |
||||
set argd [punk::args::parse {-fx xyz} withdef @opts {-fx|--filename= -default spud -type string}] |
||||
lappend result [dict get $argd opts] ;#name by default should be last flag alternative (stripped of =) ie "--filename" |
||||
#test prefixed version of flag |
||||
set argd [punk::args::parse {-f xyz} withdef @opts {-fx|--filename= -default spud -type string}] |
||||
lappend result [dict get $argd opts] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{--filename xyz}\ |
||||
{--filename xyz}\ |
||||
] |
||||
|
||||
test opts_longoptvalue_alternative_noninterference {Test -alt|--longopt= can accept longopt values as normal }\ |
||||
-setup $common -body { |
||||
#test full name of longopt |
||||
set argd [punk::args::parse {--filename=xyz} withdef @opts {-fx|--filename= -default spud -type string}] |
||||
lappend result [dict get $argd opts] ;#name by default should be last flag alternative (stripped of =) ie "--filename" |
||||
#test prefixed version of longopt |
||||
set argd [punk::args::parse {--file=xyz} withdef @opts {-fx|--filename= -default spud -type string}] |
||||
lappend result [dict get $argd opts] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{--filename xyz}\ |
||||
{--filename xyz}\ |
||||
] |
||||
|
||||
test opts_longoptvalue_choice {Test --longopt= works wiith -choices}\ |
||||
-setup $common -body { |
||||
#prefixed choice with and without prefixed flagname |
||||
set argd [punk::args::parse {--filename=x} withdef @opts {--filename= -default spud -type string -choices {abc xyz}}] |
||||
lappend result [dict get $argd opts] |
||||
set argd [punk::args::parse {--file=x} withdef @opts {--filename= -default spud -type string -choices {abc xyz}}] |
||||
lappend result [dict get $argd opts] |
||||
#unprefixed choice with and without prefixed flagname |
||||
set argd [punk::args::parse {--filename=xyz} withdef @opts {--filename= -default spud -type string -choices {abc xyz}}] |
||||
lappend result [dict get $argd opts] |
||||
set argd [punk::args::parse {--file=xyz} withdef @opts {--filename= -default spud -type string -choices {abc xyz}}] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{--filename xyz}\ |
||||
{--filename xyz}\ |
||||
{--filename xyz}\ |
||||
{--filename xyz}\ |
||||
] |
||||
} |
||||
@ -1,151 +1,175 @@
|
||||
|
||||
package require tcltest |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
namespace import ::punk::ansi::a+ ::punk::ansi::a |
||||
variable common { |
||||
set result "" |
||||
} |
||||
test synopsis_basic {test basic synopsis of punkargs definition}\ |
||||
-setup $common -body { |
||||
#no @cmd -summary |
||||
#we still expect and require a leading line "# " in the synopsis |
||||
namespace eval testns { |
||||
punk::args::define { |
||||
@id -id ::testspace::testns::t1 |
||||
@leaders |
||||
a1 -optional 0 |
||||
@opts |
||||
-o1 -type boolean |
||||
@values |
||||
v1 -optional 1 |
||||
} |
||||
} |
||||
lappend result [punk::ns::synopsis ::testspace::testns::t1] |
||||
}\ |
||||
-cleanup { |
||||
namespace delete ::testspace::testns |
||||
}\ |
||||
-result [list\ |
||||
"# \n::testspace::testns::t1 [a+ italic]a1[a+ noitalic] ?-o1 <[a+ italic]bool[a+ noitalic]>? ?[a+ italic]v1[a+ noitalic]?" |
||||
] |
||||
|
||||
test synopsis_basic_ensemble-like {test basic synopsis of punkargs ensemble-like definition}\ |
||||
-setup $common -body { |
||||
namespace eval testns { |
||||
punk::args::define { |
||||
@id -id ::testspace::testns::t1 |
||||
@cmd -summary "summary" |
||||
@leaders |
||||
subcmd -default c1 -choices {c1 c2} |
||||
@values -min 0 -max 0 |
||||
} |
||||
punk::args::define { |
||||
@id -id "::testspace::testns::t1 c1" |
||||
@cmd -summary "summary" |
||||
@values -min 0 -max 1 |
||||
v1 -type string |
||||
} |
||||
|
||||
} |
||||
lappend result [punk::ns::synopsis ::testspace::testns::t1] |
||||
lappend result [punk::ns::synopsis ::testspace::testns::t1 c1] |
||||
}\ |
||||
-cleanup { |
||||
namespace delete ::testspace::testns |
||||
}\ |
||||
-result [list\ |
||||
"# summary\n::testspace::testns::t1 ?[a+ italic]subcmd[a+ noitalic]?"\ |
||||
"# summary\n::testspace::testns::t1 c1 [a+ italic]v1[a+ noitalic]" |
||||
] |
||||
|
||||
test synopsis_alias_longopt_requiredval {}\ |
||||
-setup $common -body { |
||||
namespace eval testns { |
||||
punk::args::define { |
||||
@id -id ::testspace::testns::t1 |
||||
@cmd -summary summary |
||||
--verbose= -type int -default unreceived |
||||
} |
||||
} |
||||
lappend result [punk::ns::synopsis ::testspace::testns::t1] |
||||
#test that missing flag uses -default value |
||||
set argd [punk::args::parse {} withid ::testspace::testns::t1] |
||||
lappend result [dict get $argd opts] |
||||
#test prefix version of longopt accepts supplied int |
||||
set argd [punk::args::parse {--v=33} withid ::testspace::testns::t1] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
if {[catch { |
||||
set argd [punk::args::parse {--v=} withid ::testspace::testns::t1] |
||||
} eMsg eOpts]} { |
||||
lappend result "expected-error1" |
||||
} else { |
||||
lappend result "missing-required-error1" |
||||
} |
||||
|
||||
if {[catch { |
||||
set argd [punk::args::parse {--v} withid ::testspace::testns::t1] |
||||
} eMsg eOpts]} { |
||||
lappend result "expected-error2" |
||||
} else { |
||||
lappend result "missing-required-error2" |
||||
} |
||||
|
||||
|
||||
}\ |
||||
-cleanup { |
||||
namespace delete ::testspace::testns |
||||
}\ |
||||
-result [list\ |
||||
"# summary\n::testspace::testns::t1 ?--verbose=<[a+ italic]int[a+ noitalic]>?"\ |
||||
{--verbose unreceived}\ |
||||
{--verbose 33}\ |
||||
expected-error1\ |
||||
expected-error2 |
||||
] |
||||
|
||||
test synopsis_alias_longopt_optionalval {}\ |
||||
-setup $common -body { |
||||
namespace eval testns { |
||||
punk::args::define { |
||||
@id -id ::testspace::testns::t1 |
||||
@cmd -summary summary |
||||
--verbose= -type ?int? -default unreceived -typedefaults received |
||||
} |
||||
} |
||||
lappend result [punk::ns::synopsis ::testspace::testns::t1] |
||||
#test that missing flag uses -default value |
||||
set argd [punk::args::parse {} withid ::testspace::testns::t1] |
||||
lappend result [dict get $argd opts] |
||||
#test prefix version of longopt accepts supplied int |
||||
set argd [punk::args::parse {--v=33} withid ::testspace::testns::t1] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
if {[catch { |
||||
set argd [punk::args::parse {--v=} withid ::testspace::testns::t1] |
||||
} eMsg eOpts]} { |
||||
#expect fail due to received empty string failing <int> |
||||
lappend result "expected-error1" |
||||
} else { |
||||
lappend result "missing-required-error1" |
||||
} |
||||
|
||||
#because the type is optional (?int?) - we expect the longopt to support solo operation. |
||||
#It should pick up the -typedefaults value as a default (not -default, which is for missing flag only) |
||||
set argd [punk::args::parse {--v} withid ::testspace::testns::t1] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
}\ |
||||
-cleanup { |
||||
namespace delete ::testspace::testns |
||||
}\ |
||||
-result [list\ |
||||
"# summary\n::testspace::testns::t1 ?--verbose[a+ italic strike]?[a+ noitalic nostrike]=<[a+ italic]int[a+ noitalic]>[a+ italic strike]?[a+ noitalic nostrike]?"\ |
||||
{--verbose unreceived}\ |
||||
{--verbose 33}\ |
||||
expected-error1\ |
||||
{--verbose received} |
||||
] |
||||
} |
||||
|
||||
package require tcltest |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
namespace import ::punk::ansi::a+ ::punk::ansi::a |
||||
variable common { |
||||
set result "" |
||||
} |
||||
test synopsis_basic {test basic synopsis of punkargs definition}\ |
||||
-setup $common -body { |
||||
#no @cmd -summary |
||||
#we still expect and require a leading line "# " in the synopsis |
||||
namespace eval testns { |
||||
punk::args::define { |
||||
@id -id ::testspace::testns::t1 |
||||
@leaders |
||||
a1 -optional 0 |
||||
@opts |
||||
-o1 -type boolean |
||||
@values |
||||
v1 -optional 1 |
||||
} |
||||
} |
||||
set syntext [punk::ns::synopsis ::testspace::testns::t1] |
||||
set remlines [list] |
||||
foreach ln [split $syntext \n] { |
||||
if {[string match "##*" $ln]} {continue} |
||||
lappend remlines $ln |
||||
} |
||||
lappend result [join $remlines \n] |
||||
}\ |
||||
-cleanup { |
||||
namespace delete ::testspace::testns |
||||
}\ |
||||
-result [list\ |
||||
"# \n::testspace::testns::t1 [a+ italic]a1[a+ noitalic] \[-o1 [a+ italic]<bool>[a+ noitalic]\] \[[a+ italic]v1[a+ noitalic]\]" |
||||
] |
||||
|
||||
test synopsis_basic_ensemble-like {test basic synopsis of punkargs ensemble-like definition}\ |
||||
-setup $common -body { |
||||
namespace eval testns { |
||||
punk::args::define { |
||||
@id -id ::testspace::testns::t1 |
||||
@cmd -summary "summary" |
||||
@leaders |
||||
subcmd -default c1 -choices {c1 c2} |
||||
@values -min 0 -max 0 |
||||
} |
||||
punk::args::define { |
||||
@id -id "::testspace::testns::t1 c1" |
||||
@cmd -summary "summary" |
||||
@values -min 0 -max 1 |
||||
v1 -type string |
||||
} |
||||
|
||||
} |
||||
#strip out the secondary form lines starting with ##. |
||||
#lappend result [punk::ansi::grepstr -return matched {^(?!##)} [punk::ns::synopsis ::testspace::testns::t1]] |
||||
lappend result [grepstr -h + -return matched -v {^##} [punk::ns::synopsis ::testspace::testns::t1]] |
||||
#lappend result [grepstr -return matched {^(?!##)} [punk::ns::synopsis ::testspace::testns::t1 c1]] |
||||
lappend result [grepstr -h + -return matched -v {^##} [punk::ns::synopsis ::testspace::testns::t1 c1]] |
||||
}\ |
||||
-cleanup { |
||||
namespace delete ::testspace::testns |
||||
}\ |
||||
-result [list\ |
||||
"# summary\n::testspace::testns::t1 \[[a+ italic]subcmd[a+ noitalic]\]"\ |
||||
"# summary\n::testspace::testns::t1 c1 [a+ italic]v1[a+ noitalic]" |
||||
] |
||||
|
||||
test synopsis_alias_longopt_requiredval {}\ |
||||
-setup $common -body { |
||||
namespace eval testns { |
||||
punk::args::define { |
||||
@id -id ::testspace::testns::t1 |
||||
@cmd -summary summary |
||||
--verbose= -type int -default unreceived |
||||
} |
||||
} |
||||
#lappend result [grepstr -return matched {^(?!##)} [punk::ns::synopsis ::testspace::testns::t1]] |
||||
lappend result [grepstr -h + -return matched -v {^##} [punk::ns::synopsis ::testspace::testns::t1]] |
||||
|
||||
#test that missing flag uses -default value |
||||
set argd [punk::args::parse {} withid ::testspace::testns::t1] |
||||
lappend result [dict get $argd opts] |
||||
#test prefix version of longopt accepts supplied int |
||||
set argd [punk::args::parse {--v=33} withid ::testspace::testns::t1] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
if {[catch { |
||||
set argd [punk::args::parse {--v=} withid ::testspace::testns::t1] |
||||
} eMsg eOpts]} { |
||||
lappend result "expected-error1" |
||||
} else { |
||||
lappend result "missing-required-error1" |
||||
} |
||||
|
||||
if {[catch { |
||||
set argd [punk::args::parse {--v} withid ::testspace::testns::t1] |
||||
} eMsg eOpts]} { |
||||
lappend result "expected-error2" |
||||
} else { |
||||
lappend result "missing-required-error2" |
||||
} |
||||
|
||||
|
||||
}\ |
||||
-cleanup { |
||||
namespace delete ::testspace::testns |
||||
}\ |
||||
-result [list\ |
||||
"# summary\n::testspace::testns::t1 \[--verbose=[a+ italic]<int>[a+ noitalic]\]"\ |
||||
{--verbose unreceived}\ |
||||
{--verbose 33}\ |
||||
expected-error1\ |
||||
expected-error2 |
||||
] |
||||
|
||||
test synopsis_alias_longopt_optionalval {}\ |
||||
-setup $common -body { |
||||
namespace eval testns { |
||||
punk::args::define { |
||||
@id -id ::testspace::testns::t1 |
||||
@cmd -summary summary |
||||
--verbose= -type ?int? -default unreceived -typedefaults received |
||||
} |
||||
} |
||||
|
||||
#test relies heavily on overtype::renderline behaviour within call to grepstr -h + to return the original lines with ANSI intact, |
||||
#We should ensure that overtype tests also reflect this required behaviour. |
||||
|
||||
#this test is also very specific about the required ANSI such as italics for the synopsis. |
||||
#italics differentiate literal strings from variable names and types and are also applied to nested optional values to make the synopsis easier to read. |
||||
#We should ensure that the synopsis tests also reflect this required behaviour. |
||||
#todo - consider referencing some of these tests from the code where it's implemented. |
||||
|
||||
#lappend result [grepstr -return matched {^(?!##)} [punk::ns::synopsis ::testspace::testns::t1]] |
||||
|
||||
#use -highlight + with negated match to return the original lines with ANSI intact |
||||
lappend result [grepstr -h + -return matched -v {^##} [punk::ns::synopsis ::testspace::testns::t1]] |
||||
|
||||
#test that missing flag uses -default value |
||||
set argd [punk::args::parse {} withid ::testspace::testns::t1] |
||||
lappend result [dict get $argd opts] |
||||
#test prefix version of longopt accepts supplied int |
||||
set argd [punk::args::parse {--v=33} withid ::testspace::testns::t1] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
if {[catch { |
||||
set argd [punk::args::parse {--v=} withid ::testspace::testns::t1] |
||||
} eMsg eOpts]} { |
||||
#expect fail due to received empty string failing <int> |
||||
lappend result "expected-error1" |
||||
} else { |
||||
lappend result "missing-required-error1" |
||||
} |
||||
|
||||
#because the type is optional (?int?) - we expect the longopt to support solo operation. |
||||
#It should pick up the -typedefaults value as a default (not -default, which is for missing flag only) |
||||
set argd [punk::args::parse {--v} withid ::testspace::testns::t1] |
||||
lappend result [dict get $argd opts] |
||||
|
||||
}\ |
||||
-cleanup { |
||||
namespace delete ::testspace::testns |
||||
}\ |
||||
-result [list\ |
||||
"# summary\n::testspace::testns::t1 \[--verbose[a+ italic]\[[a+ noitalic]=[a+ italic]<int>\][a+ noitalic]\]"\ |
||||
{--verbose unreceived}\ |
||||
{--verbose 33}\ |
||||
expected-error1\ |
||||
{--verbose received} |
||||
] |
||||
} |
||||
|
||||
@ -0,0 +1,57 @@
|
||||
package require tcltest |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
variable common { |
||||
set result "" |
||||
} |
||||
|
||||
test linelist_default_trimming {}\ |
||||
-setup $common -body { |
||||
#default -block is {trimhead1 trimtail1} which should trim 1 line from head and tail if they are empty. |
||||
lappend result [punk::lib::linelist "line1\nline2\nline3"] ;# -> {line1 line2 line3} |
||||
lappend result [punk::lib::linelist "\nline1\nline2\nline3\n"] ;# -> {line1 line2 line3} |
||||
lappend result [punk::lib::linelist "\n\nline1\nline2\nline3\n\n"] ;# -> {{} line1 line2 line3 {}} |
||||
lappend result [punk::lib::linelist "\n\nline1\nline2\nline3\n\n\n"] ;# -> {{} line1 line2 line3 {} {}} |
||||
lappend result [punk::lib::linelist "\n\nline1\nline2\nline3\n"] ;# -> {{} line1 line2 line3} |
||||
#make sure only head and tail are trimmed, not inner empty lines. |
||||
lappend result [punk::lib::linelist "\nline1\n\nline2\n\n\nline3\n"] ;# -> {line1 {} line2 {} {} line3} |
||||
|
||||
|
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{line1 line2 line3} \ |
||||
{line1 line2 line3} \ |
||||
{{} line1 line2 line3 {}} \ |
||||
{{} line1 line2 line3 {} {}} \ |
||||
{{} line1 line2 line3} \ |
||||
{line1 {} line2 {} {} line3} \ |
||||
] |
||||
|
||||
|
||||
test linelist_block_collateempty {}\ |
||||
-setup $common -body { |
||||
#with -block collateempty empty (and without trimhead1 and trimtail1) lines should be collated together into single empty lines. |
||||
lappend result [punk::lib::linelist -block collateempty "line1\nline2\nline3"] ;# -> {line1 line2 line3} |
||||
lappend result [punk::lib::linelist -block collateempty "\nline1\nline2\nline3\n"] ;# -> {{} line1 line2 line3 {}} |
||||
lappend result [punk::lib::linelist -block collateempty "\n\nline1\nline2\nline3\n\n"] ;# -> {{} line1 line2 line3 {}} |
||||
lappend result [punk::lib::linelist -block collateempty "\n\nline1\nline2\nline3\n\n\n"] ;# -> {{} line1 line2 line3 {}} |
||||
lappend result [punk::lib::linelist -block collateempty "\n\nline1\nline2\nline3\n"] ;# -> {{} line1 line2 line3 {}} |
||||
lappend result [punk::lib::linelist -block collateempty "\nline1\n\nline2\n\n\nline3\n"] ;# -> {{} line1 line2 line3 {}} |
||||
|
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{line1 line2 line3} \ |
||||
{{} line1 line2 line3 {}} \ |
||||
{{} line1 line2 line3 {}} \ |
||||
{{} line1 line2 line3 {}} \ |
||||
{{} line1 line2 line3 {}} \ |
||||
{{} line1 line2 line3 {}} |
||||
] |
||||
|
||||
|
||||
} |
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,764 @@
|
||||
namespace eval voo { |
||||
# package version |
||||
variable version 1.0.0 |
||||
variable handlerToObjectMap {} |
||||
variable handlerCounter 0 |
||||
|
||||
|
||||
##\brief Check if a namespace is a valid voo class |
||||
# \param[in] namespaceName the namespace to check |
||||
# \return 1 if valid voo class, 0 otherwise |
||||
proc isVooClass {namespaceName} { |
||||
if {![uplevel [list namespace exists $namespaceName]]} { |
||||
return 0 |
||||
} |
||||
return [expr {[uplevel [list namespace eval $namespaceName { |
||||
info exists __defaultObj |
||||
}]]}] |
||||
} |
||||
|
||||
##\brief Declare a new voo class namespace and process its class body |
||||
# \param[in] args Arguments for class declaration: <className> <body> and optional -extends parent |
||||
# \note Creates the class namespace, imports parent fields/methods when using -extends, |
||||
# and registers constructors and exports |
||||
proc class {args} { |
||||
set optDict {} |
||||
set defaultArgs {} |
||||
set numArgs [llength $args] |
||||
for {set i 0} {$i < $numArgs} {incr i} { |
||||
set arg [lindex $args $i] |
||||
if {$arg eq "-extends"} { |
||||
if {$i + 1 >= $numArgs} { |
||||
error "Constructor option ’$arg’ requires an argument" |
||||
} |
||||
dict set optDict $arg [lindex $args [incr i]] |
||||
} elseif {$arg eq "-virtual" || $arg eq "-v"} { |
||||
dict set optDict "-virtual" {} |
||||
} else { |
||||
lappend defaultArgs $arg |
||||
} |
||||
} |
||||
lassign $defaultArgs className body |
||||
set vooNs [namespace current] |
||||
# create the namespace for the class |
||||
uplevel [list namespace eval $className [subst -nocommands { |
||||
namespace path [list $vooNs] |
||||
variable __defaultObj {} |
||||
variable __fields {} |
||||
variable __tmp_isPublicEnabled 1 |
||||
}]] |
||||
|
||||
uplevel [list namespace eval $className { |
||||
##\brief Access default object for this class |
||||
# \return Default class instance (list) |
||||
# \note Used for inheritance and constructor defaults |
||||
proc class.defaultObj {} { |
||||
variable __defaultObj |
||||
return $__defaultObj |
||||
} |
||||
##\brief Get list of field names for this class |
||||
# \return List of field names in declaration order |
||||
# \note Useful for introspection and constructor -name new.args |
||||
proc class.fields {} { |
||||
variable __fields |
||||
return $__fields |
||||
} |
||||
}] |
||||
|
||||
if {[dict exists $optDict -virtual] && [dict exists $optDict -extends]} { |
||||
error "voo::class: cannot use -virtual with -extends; child classes inherit virtual automatically from a -virtual parent" |
||||
} |
||||
|
||||
if {[dict exists $optDict -virtual]} { |
||||
set normalizedClassName [uplevel [list namespace eval $className {namespace current}]] |
||||
uplevel [list namespace eval $className [list variable __voo_is_virtual_class 1]] |
||||
uplevel [list namespace eval $className [list variable __voo_class_namespace $normalizedClassName]] |
||||
# Pre-populate __defaultObj with namespace tag at index 0 BEFORE field declarations |
||||
# so that _getClassCurrNumFields returns 1 for the first field declared |
||||
uplevel [list namespace eval $className [list set __defaultObj [list $normalizedClassName]]] |
||||
} |
||||
|
||||
#81 |
||||
# variable __parentClassNamespace {} |
||||
if {[dict exists $optDict -extends]} { |
||||
set parentClassName [dict get $optDict -extends] |
||||
|
||||
if {![uplevel [list namespace exists $parentClassName]]} { |
||||
error "Parent class ’$parentClassName’ does not exist." |
||||
} |
||||
|
||||
# check if parent class exists |
||||
if {![uplevel [list namespace eval $parentClassName {info exists __defaultObj}]]} { |
||||
error "Parent class ’$parentClassName’ is not a valid voo class." |
||||
} |
||||
|
||||
# normalize namespace name of parent class |
||||
set parentClassName [uplevel [list namespace eval $parentClassName { |
||||
namespace current |
||||
}]] |
||||
|
||||
uplevel [list namespace eval $className [subst -nocommands { |
||||
variable __parentClassNamespace $parentClassName |
||||
}]] |
||||
|
||||
# import parent’s default object values |
||||
set parentDefaultObj [${parentClassName}::class.defaultObj] |
||||
uplevel [list namespace eval $className [list set __defaultObj $parentDefaultObj]] |
||||
|
||||
|
||||
# if parent is virtual, update namespace tag at index 0 to child’s namespace |
||||
set parentIsVirtual [uplevel [list namespace eval $parentClassName {info exists __voo_is_virtual_class}]] |
||||
if {$parentIsVirtual} { |
||||
set normalizedChildName [uplevel [list namespace eval $className {namespace current}]] |
||||
uplevel [list namespace eval $className \ |
||||
[list set __defaultObj [lreplace $parentDefaultObj 0 0 $normalizedChildName]]] |
||||
uplevel [list namespace eval $className [list variable __voo_is_virtual_class 1]] |
||||
uplevel [list namespace eval $className [list variable __voo_class_namespace $normalizedChildName]] |
||||
} |
||||
|
||||
# 121 |
||||
# import parent’s field index variables by copying actual index values from parent |
||||
set parentFields [${parentClassName}::class.fields] |
||||
foreach field $parentFields { |
||||
set fieldIdx [uplevel [list namespace eval $parentClassName [list set $field]]] |
||||
uplevel [list namespace eval $className [list variable $field $fieldIdx]] |
||||
uplevel [list namespace eval $className [list lappend __fields $field]] |
||||
} |
||||
|
||||
# import parent’s acessors in child class with namespace import |
||||
uplevel [list namespace eval $className [subst -nocommands { |
||||
namespace import ${parentClassName}::get.* |
||||
namespace import ${parentClassName}::set.* |
||||
namespace import ${parentClassName}::update.* |
||||
}]] |
||||
} |
||||
|
||||
|
||||
# 136 |
||||
|
||||
uplevel [list namespace eval $className $body] |
||||
|
||||
uplevel [list namespace eval $className { |
||||
if {[info commands new] eq ""} { |
||||
constructor |
||||
} |
||||
if {[info commands new()] eq ""} { |
||||
constructor -noargs [_buildConstructorNoArgsBody] |
||||
} |
||||
if {[info commands new.args] eq ""} { |
||||
constructor -name new.args {args} [_buildConstructorArgsBody] |
||||
} |
||||
}] |
||||
|
||||
|
||||
# 151 |
||||
uplevel [list namespace eval $className { |
||||
# export class methods |
||||
namespace export * |
||||
}] |
||||
|
||||
uplevel [list namespace eval $className { |
||||
# clean temporary variable |
||||
unset __tmp_isPublicEnabled |
||||
}] |
||||
return |
||||
} |
||||
|
||||
# 161 |
||||
##\brief Return the default value for a given field type |
||||
# \param[in] type the field type token (double,int,bool,...) |
||||
# \return The default value appropriate for the type |
||||
proc _getDefaultValueByType {type} { |
||||
switch -- $type { |
||||
double { return 0.0 } |
||||
int { return 0 } |
||||
bool { return 0 } |
||||
default { return {} } |
||||
} |
||||
} |
||||
|
||||
##\brief Get the current number of fields declared in the current class |
||||
# \return Number of fields (integer) |
||||
proc _getClassCurrNumFields {} { |
||||
return [uplevel 2 {llength $__defaultObj}] |
||||
} |
||||
|
||||
##\brief Check whether public mode is enabled during class body parsing |
||||
# \return 1 if public mode is enabled, 0 otherwise |
||||
proc _getClassIsPublicEnabled {} { |
||||
return [uplevel 2 {set __tmp_isPublicEnabled}] |
||||
} |
||||
|
||||
##\brief Declare getter/setter/updater accessors for a class field |
||||
# \param[in] fieldName name of the field |
||||
# \param[in] isPublic boolean whether accessors are public |
||||
# \param[in] isStatic boolean whether field is static (class-level) |
||||
proc _declareFieldAcessors {fieldName isPublic isStatic} { |
||||
set prefix {} |
||||
|
||||
if {$isStatic} { |
||||
append prefix class. |
||||
} |
||||
if {!$isPublic} { |
||||
append prefix my. |
||||
} |
||||
set getterName "${prefix}get.$fieldName" |
||||
set setterName "${prefix}set.$fieldName" |
||||
set updaterName "${prefix}update.$fieldName" |
||||
if {$isStatic} { |
||||
uplevel 2 [list proc $getterName {} [subst -nocommands { |
||||
variable $fieldName |
||||
return $$fieldName |
||||
}]] |
||||
uplevel 2 [list proc $setterName {value} [subst -nocommands { |
||||
variable $fieldName |
||||
set $fieldName "\$value" |
||||
}]] |
||||
|
||||
uplevel 2 [list proc $updaterName {tempVar body} [subst -nocommands { |
||||
variable $fieldName |
||||
upvar "\$tempVar" temp |
||||
set temp $$fieldName |
||||
# break link with class variable to avoid copy-on-write |
||||
set $fieldName {} |
||||
try { |
||||
uplevel \$body |
||||
} finally { |
||||
set $fieldName "\$temp" |
||||
} |
||||
}]] |
||||
|
||||
} else { |
||||
uplevel 2 [list getter $getterName $fieldName] |
||||
uplevel 2 [list setter $setterName $fieldName] |
||||
uplevel 2 [list updater $updaterName $fieldName] |
||||
} |
||||
return |
||||
} |
||||
|
||||
##\brief Validate a field name for illegal characters |
||||
# \param[in] fieldName the field name to validate |
||||
# \return Raises an error if invalid |
||||
proc _validateFieldName {fieldName} { |
||||
if {[string first "." $fieldName] != -1 || [string first "::" $fieldName] != -1} { |
||||
error "Field name ’$fieldName’ cannot contain ’.’ or ’::’ substrings." |
||||
} |
||||
} |
||||
|
||||
##\brief Ensure a field name does not already exist in the class |
||||
# \param[in] fieldName the field name to check |
||||
# \return Raises an error if the field already exists |
||||
# \note Uses __fields for instance fields and fully-qualified namespace lookup for static |
||||
# fields to avoid false positives from global variables with the same name |
||||
proc _validateFieldDoesNotExist {fieldName} { |
||||
# Check instance fields tracked in __fields (class-scoped, no global bleed) |
||||
if {$fieldName in [uplevel 2 {set __fields}]} { |
||||
error "Field name ’$fieldName’ already exists in the class." |
||||
} |
||||
# Check static fields via fully-qualified namespace variable; info exists ::Ns::var |
||||
# only matches that exact namespace variable, never a same-named global |
||||
set classNs [uplevel 2 {namespace current}] |
||||
if {[info exists ${classNs}::$fieldName]} { |
||||
error "Field name ’$fieldName’ already exists in the class." |
||||
} |
||||
} |
||||
|
||||
##\brief Validate a variable initial value according to its declared type |
||||
# \param[in] type the declared type (double,int,bool,list,dict) |
||||
# \param[in] value the value to validate |
||||
# \return Raises an error if the value does not match the type |
||||
proc _validateVarValueByType {type value} { |
||||
switch -- $type { |
||||
double { |
||||
if {[string is double -strict $value] == 0} { |
||||
error "Value for t_double must be a double, got ’$value’" |
||||
} |
||||
} |
||||
int { |
||||
if {[string is integer -strict $value] == 0} { |
||||
error "Value for t_int must be an integer, got ’$value’" |
||||
} |
||||
} |
||||
bool { |
||||
if {[string is boolean -strict $value] == 0} { |
||||
error "Value for t_bool must be a boolean, got ’$value’" |
||||
} |
||||
} |
||||
list { |
||||
if {[catch {llength $value}]} { |
||||
error "Value for t_list must be a list, got ’$value’" |
||||
} |
||||
} |
||||
dict { |
||||
if {[catch {dict size $value}]} { |
||||
error "Value for t_dict must be a dict, got ’$value’" |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
##\brief Declare a field variable inside the class body |
||||
# \param[in] type the field type token (double,int,string,bool,list,dict,obj) |
||||
# \param[in] argList arguments: ?-static? <name> ?<initialValue>? |
||||
proc _var {type argList} { |
||||
set defaultArgs {} |
||||
set optDict {} |
||||
set numArgs [llength $argList] |
||||
for {set i 0} {$i < $numArgs} {incr i} { |
||||
set arg [lindex $argList $i] |
||||
if {$arg eq "-static"} { |
||||
dict set optDict $arg {} |
||||
} else { |
||||
lappend defaultArgs $arg |
||||
} |
||||
} |
||||
if {[llength $defaultArgs] == 0} { |
||||
error "Variable definition requires: ?<option>? <name> ?<initialValue>?" |
||||
} |
||||
if {[llength $defaultArgs] == 2} { |
||||
lassign $defaultArgs name initVal |
||||
} else { |
||||
lassign $defaultArgs name |
||||
set initVal [_getDefaultValueByType $type] |
||||
} |
||||
|
||||
_validateFieldName $name |
||||
_validateFieldDoesNotExist $name |
||||
_validateVarValueByType $type $initVal |
||||
if {[dict exists $optDict -static]} { |
||||
# static field |
||||
uplevel [list variable $name $initVal] |
||||
} else { |
||||
set currNumFields [_getClassCurrNumFields] |
||||
uplevel [list variable $name $currNumFields] |
||||
uplevel [list lappend __defaultObj $initVal] |
||||
uplevel [list lappend __fields $name] |
||||
} |
||||
set isPublicEnabled [_getClassIsPublicEnabled] |
||||
_declareFieldAcessors $name $isPublicEnabled [dict exists $optDict -static] |
||||
return |
||||
} |
||||
# 341 |
||||
|
||||
##\brief Declare a double-typed field |
||||
# \param[in] args same arguments accepted by _var (name and optional initial value) |
||||
proc double_t {args} { |
||||
uplevel [list _var "double" $args] |
||||
} |
||||
|
||||
##\brief Declare an integer-typed field |
||||
# \param[in] args same arguments accepted by _var (name and optional initial value) |
||||
proc int_t {args} { |
||||
uplevel [list _var "int" $args] |
||||
} |
||||
|
||||
##\brief Declare a string-typed field |
||||
# \param[in] args same arguments accepted by _var (name and optional initial value) |
||||
proc string_t {args} { |
||||
uplevel [list _var "string" $args] |
||||
} |
||||
|
||||
##\brief Declare a boolean-typed field |
||||
# \param[in] args same arguments accepted by _var (name and optional initial value) |
||||
proc bool_t {args} { |
||||
uplevel [list _var "bool" $args] |
||||
} |
||||
|
||||
##\brief Declare a list-typed field |
||||
# \param[in] args same arguments accepted by _var (name and optional initial value) |
||||
proc list_t {args} { |
||||
uplevel [list _var "list" $args] |
||||
} |
||||
|
||||
##\brief Declare a dict-typed field |
||||
# \param[in] args same arguments accepted by _var (name and optional initial value) |
||||
proc dict_t {args} { |
||||
uplevel [list _var "dict" $args] |
||||
} |
||||
|
||||
##\brief Declare an object-typed field (nested vanilla object) |
||||
# \param[in] args same arguments accepted by _var (name and optional initial value) |
||||
proc obj_t {args} { |
||||
uplevel [list _var "object" $args] |
||||
} |
||||
|
||||
# 386 |
||||
##\brief Enable public mode for declarations inside the provided body |
||||
# \param[in] body script to execute with public accessors enabled |
||||
# \return Result of executing body |
||||
proc public {body} { |
||||
uplevel $body |
||||
} |
||||
|
||||
##\brief Execute the provided body with private mode enabled (temporarily disables public accessors) |
||||
# \param[in] body script to execute with private accessors |
||||
# \return Result of executing body |
||||
proc private {body} { |
||||
uplevel {variable __tmp_isPublicEnabled 0} |
||||
try { |
||||
uplevel $body |
||||
} finally { |
||||
uplevel {variable __tmp_isPublicEnabled 1} |
||||
} |
||||
} |
||||
|
||||
##\brief Build the body for a no-argument constructor |
||||
# \return A script chunk used as constructor body that returns the class default object |
||||
proc _buildConstructorNoArgsBody {} { |
||||
return { |
||||
variable __defaultObj |
||||
return $__defaultObj; |
||||
} |
||||
} |
||||
|
||||
##\brief Build the body for a constructor that accepts named args (-field value pairs) |
||||
# \return A script chunk used as constructor body that applies named arguments to the default object |
||||
proc _buildConstructorArgsBody {} { |
||||
return { |
||||
variable __defaultObj |
||||
set obj $__defaultObj |
||||
if {[catch {dict size $args}]} { |
||||
error "Constructor argument must be a list of ’-<field> <value>’ pairs" |
||||
} |
||||
dict for {key value} $args { |
||||
if {[string index $key 0] ne "-"} { |
||||
error "Constructor argument keys must start with ’-’, got ’$key’" |
||||
} |
||||
set field [string range $key 1 end] |
||||
set setter set.$field |
||||
if {[info commands $setter] ne ""} { |
||||
$setter obj $value |
||||
} else { |
||||
set setter my.set.$field |
||||
if {[info commands $setter] ne ""} { |
||||
$setter obj $value |
||||
} else { |
||||
error "Unknown field option: $field" |
||||
} |
||||
} |
||||
} |
||||
return $obj |
||||
} |
||||
} |
||||
|
||||
##\brief Build constructor parameter list and body for positional constructors |
||||
# \return A list of two elements: argument names list and a body script that returns them as a list |
||||
# \note For virtual classes, the concrete class namespace is embedded as a literal string at |
||||
# class-definition time (not looked up at runtime), producing: |
||||
# return [list ::ClassName $f1 $f2 ...] |
||||
# This avoids all runtime proc calls (class.defaultObj, set.*) and variable lookups, |
||||
# making virtual object creation as cheap as non-virtual. |
||||
proc _buildConstructorParams {} { |
||||
set argList [uplevel 2 {set __fields}] |
||||
set isVirtual [uplevel 2 {info exists __voo_is_virtual_class}] |
||||
set spacedArgVarListStr {} |
||||
foreach arg $argList { |
||||
append spacedArgVarListStr "\$$arg " |
||||
} |
||||
if {$isVirtual} { |
||||
# Read the normalized class namespace at definition time so subst embeds it |
||||
# as a literal in the generated body - no runtime variable lookup required. |
||||
set classNs [uplevel 2 {set __voo_class_namespace}] |
||||
set spacedArgVarListStr "{$classNs} $spacedArgVarListStr" |
||||
set body [subst -nocommands { |
||||
return [list $spacedArgVarListStr] |
||||
}] |
||||
} else { |
||||
set body [subst -nocommands { |
||||
return [list $spacedArgVarListStr] |
||||
}] |
||||
} |
||||
return [list $argList $body] |
||||
} |
||||
|
||||
##\brief Define a constructor for the current class |
||||
# \param[in] args Constructor declaration options and body |
||||
# \note Supports -name, -noargs and -typed variants |
||||
proc constructor {args} { |
||||
set defaultArgs {} |
||||
set optDict {} |
||||
set numArgs [llength $args] |
||||
for {set i 0} {$i < $numArgs} {incr i} { |
||||
set arg [lindex $args $i] |
||||
if {$arg eq "-name" || $arg eq "-noargs" || $arg eq "-typed"} { |
||||
if {$i + 1 >= $numArgs} { |
||||
error "Constructor option ’$arg’ requires an argument" |
||||
} |
||||
dict set optDict $arg [lindex $args [incr i]] |
||||
} else { |
||||
lappend defaultArgs $arg |
||||
} |
||||
} |
||||
# check valid option combinations |
||||
if {[dict exists $optDict -name]} { |
||||
if {[dict exists $optDict -noargs] || [dict exists $optDict -typed]} { |
||||
error "Constructor cannot have -name option with -noargs or -typed options" |
||||
} |
||||
} |
||||
if {[dict exists $optDict -noargs] && [dict exists $optDict -typed]} { |
||||
error "Constructor cannot have both -noargs and -typed options" |
||||
} |
||||
if {[dict exists $optDict -name]} { |
||||
set constructorName [dict get $optDict -name] |
||||
} elseif {[dict exists $optDict -noargs]} { |
||||
set constructorName "new()" |
||||
} elseif {[dict exists $optDict -typed]} { |
||||
set constructorName "new([join [dict get $optDict -typed] ,])" |
||||
} else { |
||||
set constructorName "new" |
||||
} |
||||
if {[dict exists $optDict -noargs]} { |
||||
if {[llength $defaultArgs] != 0} { |
||||
error "Invalid constructor definition, expected ’?...? ?<body>?’ for -noargs" |
||||
} |
||||
set argList {} |
||||
set body [dict get $optDict -noargs] |
||||
} else { |
||||
if {[llength $defaultArgs] == 0} { |
||||
lassign [_buildConstructorParams] argList body |
||||
} else { |
||||
if {[llength $defaultArgs] != 2} { |
||||
error "Invalid constructor definition, expected ’?...? ?<argList> <body>?’" |
||||
} |
||||
lassign $defaultArgs argList body |
||||
} |
||||
} |
||||
uplevel [list proc $constructorName $argList $body] |
||||
return |
||||
} |
||||
|
||||
|
||||
# 531 |
||||
##\brief Generate a getter procedure for a field |
||||
# \param[in] methodName name of the generated getter (may include namespace prefix) |
||||
# \param[in] fieldName name of the field to read |
||||
proc getter {methodName fieldName} { |
||||
# implementation of getter definition |
||||
set fieldIdx [uplevel [list set $fieldName]] |
||||
uplevel [subst -nocommands { |
||||
##\\brief Getter for $fieldName |
||||
# \\param\[in\] this class instance |
||||
# \\return $fieldName value |
||||
proc $methodName {this} { |
||||
return [lindex \$this $fieldIdx] |
||||
} |
||||
}] |
||||
return |
||||
} |
||||
|
||||
##\brief Generate a setter procedure for a field |
||||
# \param[in] methodName name of the generated setter (may include namespace prefix) |
||||
# \param[in] fieldName name of the field to write |
||||
proc setter {methodName fieldName} { |
||||
# implementation of setter definition |
||||
set fieldIdx [uplevel [list set $fieldName]] |
||||
uplevel [subst -nocommands { |
||||
##\\brief Setter for $fieldName |
||||
# \\param\[in\] thisVar name of variable containing class instance |
||||
# \\param\[in\] value new value for $fieldName |
||||
proc $methodName {thisVar value} { |
||||
upvar \$thisVar this |
||||
lset this $fieldIdx \$value |
||||
} |
||||
}] |
||||
return |
||||
} |
||||
|
||||
##\brief Generate an updater procedure for a field (copy-on-write safe) |
||||
# \param[in] methodName name of the generated updater (may include namespace prefix) |
||||
# \param[in] fieldName name of the field to update by reference |
||||
# \note The updater detaches the field to avoid unnecessary copying during updates |
||||
proc updater {methodName fieldName} { |
||||
# implementation of updater definition |
||||
set fieldIdx [uplevel [list set $fieldName]] |
||||
uplevel [subst -nocommands { |
||||
##\\brief Update $fieldName by reference |
||||
# \\param\[in\] thisVar name of variable containing class instance |
||||
# \\param\[out\] tempVar name of variable to hold $fieldName during update |
||||
# \\param\[in\] body script to execute with $fieldName in tempVar |
||||
# \\note Avoids copy-on-write by detaching field during update |
||||
proc $methodName {thisVar tempVar body} { |
||||
upvar \$thisVar this |
||||
upvar \$tempVar temp |
||||
set temp [lindex \$this $fieldIdx] |
||||
# break link with object to avoid copy-on-write |
||||
lset this $fieldIdx {} |
||||
try { |
||||
uplevel \$body |
||||
} finally { |
||||
lset this $fieldIdx \$temp |
||||
} |
||||
} |
||||
}] |
||||
} |
||||
|
||||
##\brief Declare a method in the current class namespace |
||||
# \param[in] args Method declaration arguments: name, argList, body and options (-static, -upvar, -update, -override) |
||||
proc method {args} { |
||||
set isPublicEnabled [_getClassIsPublicEnabled] |
||||
set defaultArgs {} |
||||
set optDict {} |
||||
set numArgs [llength $args] |
||||
for {set i 0} {$i < $numArgs} {incr i} { |
||||
set arg [lindex $args $i] |
||||
if {$arg eq "-static" || $arg eq "-upvar"} { |
||||
dict set optDict $arg {} |
||||
} elseif {$arg eq "-update"} { |
||||
if {$i + 1 >= $numArgs} { |
||||
error "Method option ’$arg’ requires an argument" |
||||
} |
||||
dict set optDict $arg [lindex $args [incr i]] |
||||
} elseif {$arg eq "-override"} { |
||||
# Explicit override indicator |
||||
dict set optDict $arg {} |
||||
} elseif {$arg eq "-virtual"} { |
||||
dict set optDict $arg {} |
||||
} else { |
||||
lappend defaultArgs $arg |
||||
} |
||||
} |
||||
lassign $defaultArgs name argList body |
||||
|
||||
# check valid option combinations |
||||
if {[dict exists $optDict -static]} { |
||||
if {[dict exists $optDict -upvar] || [dict exists $optDict -update]} { |
||||
error "Method cannot have both -static and -upvar or -update options" |
||||
} |
||||
} |
||||
if {[dict exists $optDict -update]} { |
||||
if {![dict exists $optDict -upvar]} { |
||||
# automatically add -upvar if -update is specified |
||||
dict set optDict -upvar {} |
||||
} |
||||
} |
||||
set finalArgList {} |
||||
set finalBody {} |
||||
if {[dict exists $optDict -upvar]} { |
||||
lappend finalArgList "thisVar" |
||||
append finalBody { |
||||
upvar $thisVar this |
||||
} |
||||
} elseif {![dict exists $optDict -static]} { |
||||
lappend finalArgList "this" |
||||
} |
||||
lappend finalArgList {*}$argList |
||||
set className [uplevel {namespace current}] |
||||
if {[dict exists $optDict -update]} { |
||||
set updateFields [dict get $optDict -update] |
||||
if {[llength $updateFields] == 0} { |
||||
error "-update option requires at least one field name" |
||||
} |
||||
foreach field $updateFields { |
||||
try { |
||||
set fieldIdx [uplevel [list set $field]] |
||||
} trap {} {} { |
||||
error "Field ’$field’ specified in -update option does not exist in class ’$className’" |
||||
} |
||||
append finalBody [subst -nocommands { |
||||
set $field [lindex \$this $fieldIdx] |
||||
lset this $fieldIdx {} |
||||
}] |
||||
} |
||||
append finalBody "try \{" |
||||
} |
||||
append finalBody $body |
||||
if {[dict exists $optDict -update]} { |
||||
append finalBody "\} finally \{" |
||||
foreach field $updateFields { |
||||
set fieldIdx [uplevel [list set $field]] |
||||
append finalBody [subst -nocommands { |
||||
lset this $fieldIdx \$$field |
||||
}] |
||||
} |
||||
append finalBody "\}" |
||||
} |
||||
if {!$isPublicEnabled} { |
||||
set name "my.$name" |
||||
} |
||||
if {[dict exists $optDict -override]} { |
||||
set parentNs [uplevel {set __parentClassNamespace}] |
||||
if {[info commands "${parentNs}::$name"] eq ""} { |
||||
error "Method ’$name’ does not override any method in parent class ’$parentNs’" |
||||
} |
||||
# If parent’s method is virtual (has base.<name>), auto-promote this override |
||||
# to a dispatcher so that deep inheritance dispatch works correctly |
||||
if {[uplevel {info exists __voo_is_virtual_class}] && \ |
||||
[info commands "${parentNs}::base.$name"] ne ""} { |
||||
dict set optDict -virtual {} |
||||
} |
||||
} |
||||
if {[dict exists $optDict -virtual]} { |
||||
if {![uplevel {info exists __voo_is_virtual_class}]} { |
||||
error "Method ’$name’ is declared -virtual but ’[uplevel {namespace current}]’ is not a virtual class" |
||||
} |
||||
if {[dict exists $optDict -upvar] || [dict exists $optDict -update] || [dict exists $optDict -static]} { |
||||
error "Method ’$name’ cannot combine -virtual with -upvar, -update, or -static" |
||||
} |
||||
# Register base.<name> with the original body for direct parent calls from subclasses |
||||
uplevel [list proc "base.$name" $finalArgList $finalBody] |
||||
# Build dispatch body: route to concrete class implementation at runtime |
||||
set dispatchBody "set __voo_cls \[lindex \$this 0\]\n" |
||||
append dispatchBody "if \{\$__voo_cls ne \[namespace current\] && \[info commands \${__voo_cls}::$name\] ne {}\} \{\n" |
||||
append dispatchBody " return \[\${__voo_cls}::$name \$this" |
||||
foreach arg $argList { |
||||
append dispatchBody " \$$arg" |
||||
} |
||||
append dispatchBody "\]\n\}\n" |
||||
append dispatchBody "return \[base.$name \$this" |
||||
foreach arg $argList { |
||||
append dispatchBody " \$$arg" |
||||
} |
||||
append dispatchBody "\]" |
||||
set finalBody $dispatchBody |
||||
} |
||||
uplevel [list proc $name $finalArgList $finalBody] |
||||
return |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# 726 |
||||
|
||||
##\brief Import one or more methods from parent class into the current (child) class namespace. |
||||
# \param[in] methods List of method names (or a single method name) to import from parent. |
||||
# \note Must be called inside a class declared with -extends. Methods are copied at class-definition time. |
||||
proc importMethods {methods} { |
||||
set parentNs [uplevel {set __parentClassNamespace}] |
||||
# Validate caller context and get parent namespace stored by -extends handling |
||||
if {$parentNs eq ""} { |
||||
error "importMethods can only be used inside a class declared with -extends" |
||||
} |
||||
# Normalize to a list of method names |
||||
if {[string length [string trim $methods]] == 0} { |
||||
return |
||||
} |
||||
if {[catch {llength $methods}]} { |
||||
set methodList [list $methods] |
||||
} else { |
||||
set methodList $methods |
||||
} |
||||
foreach methodName $methodList { |
||||
set fullMethodName "${parentNs}::$methodName" |
||||
# Validate parent method exists |
||||
if {[info commands $fullMethodName] eq ""} { |
||||
error "Method ’$methodName’ not found in parent class ’$parentNs’" |
||||
} |
||||
# Define a copy in the child namespace so unqualified calls resolve to child |
||||
set argList [info args $fullMethodName] |
||||
set body [info body $fullMethodName] |
||||
uplevel [list proc $methodName $argList $body] |
||||
} |
||||
return |
||||
} |
||||
|
||||
namespace export * |
||||
} |
||||
# provide the package |
||||
package provide voo $::voo::version |
||||
|
||||
File diff suppressed because it is too large
Load Diff
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in new issue