From 7a170a6a460f73ac673e4eb183b5d3805b64d181 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Fri, 17 Jul 2026 21:54:54 +1000 Subject: [PATCH] argparsingtest 0.2.0: parser timing comparison with cold+warm first-call metrics New procs timeit/compare/discover_parsers/first_call for rough cross-parser performance comparison (punk::args variants vs hand-rolled dict/switch/prefix, tcllib opt/cmdline/tepam, argp), with PUNKARGS argdoc coverage throughout. first_call times each parser twice in fresh child interps: - cold: first call after package load (includes byte-compilation of the parser proc body and any backing-library procs it invokes) - warm: the backing library is pre-exercised via per-library sacrificial warm-up scripts (library_warmups dict) so the timed call isolates per-proc first-use cost. Replaces an earlier punk::args-only 'punk::args::parse {} withdef {}' warm hack that was unfair to the other libraries under test and only partially warmed punk::args itself. Child interps pin package requires to the parent's loaded versions (punk::args, punk::lib when present, argparsingtest) - plain package require prefers stable versions, so children otherwise timed older stable copies visible on the module paths instead of the dev module under test; under Tcl 8.6 the punk::lib pin also supplies the lpop compat shim punk::args::parse needs, unbreaking punk::args timing in bare child interps there. compare renders first_cold/first_warm columns (table), nested cold/warm sub-dicts (dict/json). New test suite under src/tests/modules/argparsingtest. Assisted-by: harness=claude; primary-model=claude-fable-5; api-location=anthropic.com --- src/modules/argparsingtest-999999.0a1.0.tm | 929 ++++++++++++++++++ src/modules/argparsingtest-buildversion.txt | 5 +- .../argparsingtest/argparsingtest.test | 145 +++ 3 files changed, 1078 insertions(+), 1 deletion(-) create mode 100644 src/tests/modules/argparsingtest/testsuites/argparsingtest/argparsingtest.test diff --git a/src/modules/argparsingtest-999999.0a1.0.tm b/src/modules/argparsingtest-999999.0a1.0.tm index 10950bb5..00a7bfc8 100644 --- a/src/modules/argparsingtest-999999.0a1.0.tm +++ b/src/modules/argparsingtest-999999.0a1.0.tm @@ -109,6 +109,23 @@ namespace eval argparsingtest { #[para] Core API functions for argparsingtest #[list_begin definitions] + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::argparsingtest::test1_ni + @cmd -name test1_ni -summary "dict merge with ni check" -help "Accepts 10 keyed options. Validates each key using ni (not-in) check; errors on unknown keys." + @opts -anyopts 0 + -return -default string -type string + -frametype -default \uFFEF -type string + -show_edge -default \uFFEF -type string + -show_seps -default \uFFEF -type string + -x -default "" -type string + -y -default b -type string + -z -default c -type string + -1 -default 1 -type boolean + -2 -default 2 -type integer + -3 -default 3 -type integer + }] + } proc test1_ni {args} { set defaults [dict create {*}{ -return string @@ -129,6 +146,23 @@ namespace eval argparsingtest { } set opts [dict merge $defaults $args] } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::argparsingtest::test1_switchmerge + @cmd -name test1_switchmerge -summary "switch validation with dict merge" -help "Accepts 10 keyed options. Validates each key via switch then merges into defaults dict." + @opts -anyopts 0 + -return -default string -type string + -frametype -default \uFFEF -type string + -show_edge -default \uFFEF -type string + -show_seps -default \uFFEF -type string + -x -default "" -type string + -y -default b -type string + -z -default c -type string + -1 -default 1 -type boolean + -2 -default 2 -type integer + -3 -default 3 -type integer + }] + } proc test1_switchmerge {args} { set defaults [dict create {*}{ -return string @@ -153,6 +187,23 @@ namespace eval argparsingtest { set opts [dict merge $defaults $args] } #if we need to loop to test arg validity anyway - then dict set as we go is slightly faster than a dict merge at the end + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::argparsingtest::test1_switch + @cmd -name test1_switch -summary "switch-based arg parsing with dict set" -help "Accepts 10 keyed options. Uses switch to validate and dict set each value; slightly faster than dict merge." + @opts -anyopts 0 + -return -default string -type string + -frametype -default \uFFEF -type string + -show_edge -default \uFFEF -type string + -show_seps -default \uFFEF -type string + -x -default "" -type string + -y -default b -type string + -z -default c -type string + -1 -default 1 -type boolean + -2 -default 2 -type integer + -3 -default 3 -type integer + }] + } proc test1_switch {args} { set opts [dict create {*}{ -return string @@ -192,6 +243,23 @@ namespace eval argparsingtest { -3 3 }] #slightly slower than just creating the dict within the proc + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::argparsingtest::test1_switch_nsvar + @cmd -name test1_switch_nsvar -summary "switch with namespace variable defaults" -help "Accepts 10 keyed options. Reads defaults from module-level variable switchopts; slightly slower than local dict creation." + @opts -anyopts 0 + -return -default string -type string + -frametype -default \uFFEF -type string + -show_edge -default \uFFEF -type string + -show_seps -default \uFFEF -type string + -x -default "" -type string + -y -default b -type string + -z -default c -type string + -1 -default 1 -type boolean + -2 -default 2 -type integer + -3 -default 3 -type integer + }] + } proc test1_switch_nsvar {args} { variable switchopts set opts $switchopts @@ -207,6 +275,23 @@ namespace eval argparsingtest { } return $opts } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::argparsingtest::test1_switch2 + @cmd -name test1_switch2 -summary "switch with lmap-built switch arms" -help "Accepts 10 keyed options. Builds the switch arm list from dict keys via lmap then dispatches with expand." + @opts -anyopts 0 + -return -default string -type string + -frametype -default \uFFEF -type string + -show_edge -default \uFFEF -type string + -show_seps -default \uFFEF -type string + -x -default "" -type string + -y -default b -type string + -z -default c -type string + -1 -default 1 -type boolean + -2 -default 2 -type integer + -3 -default 3 -type integer + }] + } proc test1_switch2 {args} { set opts [dict create {*}{ -return string @@ -234,6 +319,23 @@ namespace eval argparsingtest { } return $opts } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::argparsingtest::test1_prefix + @cmd -name test1_prefix -summary "prefix-match based arg parsing" -help "Accepts 10 keyed options. Uses tcl::prefix::match for unique-prefix matching on each call." + @opts -anyopts 0 + -return -default string -type string + -frametype -default \uFFEF -type string + -show_edge -default \uFFEF -type string + -show_seps -default \uFFEF -type string + -x -default "" -type string + -y -default b -type string + -z -default c -type string + -1 -default 1 -type boolean + -2 -default 2 -type integer + -3 -default 3 -type integer + }] + } proc test1_prefix {args} { set opts [dict create {*}{ -return string @@ -252,6 +354,23 @@ namespace eval argparsingtest { } return $opts } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::argparsingtest::test1_prefix2 + @cmd -name test1_prefix2 -summary "prefix-match with cached knownflags" -help "Accepts 10 keyed options. Uses tcl::prefix::match with knownflags cached on first non-empty call." + @opts -anyopts 0 + -return -default string -type string + -frametype -default \uFFEF -type string + -show_edge -default \uFFEF -type string + -show_seps -default \uFFEF -type string + -x -default "" -type string + -y -default b -type string + -z -default c -type string + -1 -default 1 -type boolean + -2 -default 2 -type integer + -3 -default 3 -type integer + }] + } proc test1_prefix2 {args} { set opts [dict create {*}{ -return string @@ -275,6 +394,24 @@ namespace eval argparsingtest { } #punk::args is slower than argp - but comparable, and argp doesn't support solo flags + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::argparsingtest::test1_punkargs + @cmd -name test1_punkargs -summary "punk::args withdef string types" -help "Accepts 10 keyed options plus -join. Uses punk::args::parse withdef with string types." + @opts -anyopts 0 + -return -default string -type string + -frametype -default \uFFEF -type string + -show_edge -default \uFFEF -type string + -show_seps -default \uFFEF -type string + -x -default "" -type string + -y -default b -type string + -z -default c -type string + -1 -default 1 -type boolean + -2 -default 2 -type integer + -3 -default 3 -type integer + -join -type none -multiple 1 + }] + } proc test1_punkargs {args} { set argd [punk::args::parse $args withdef { @id -id ::argparsingtest::test1_punkargs @@ -296,6 +433,24 @@ namespace eval argparsingtest { return [tcl::dict::get $argd opts] } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::argparsingtest::test1_punkargs_any + @cmd -name test1_punkargs_any -summary "punk::args withdef any types" -help "Accepts 10 keyed options plus -join. Uses withdef with -type any for all string-like opts." + @opts -anyopts 0 + -return -default string -type any + -frametype -default \uFFEF -type any + -show_edge -default \uFFEF -type any + -show_seps -default \uFFEF -type any + -x -default "" -type any + -y -default b -type any + -z -default c -type any + -1 -default 1 -type boolean + -2 -default 2 -type integer + -3 -default 3 -type integer + -join -type none -multiple 1 + }] + } proc test1_punkargs_any {args} { set argd [punk::args::parse $args withdef { @id -id ::argparsingtest::test1_punkargs @@ -334,17 +489,71 @@ namespace eval argparsingtest { -3 -default 3 -type integer @values } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::argparsingtest::test1_punkargs_by_id + @cmd -name test1_punkargs_by_id -summary "punk::args withid pre-registered" -help "Accepts 10 keyed options plus -join. Parses via a pre-registered definition using withid." + @opts -anyopts 0 + -return -default string -type string + -frametype -default \uFFEF -type string + -show_edge -default \uFFEF -type string + -show_seps -default \uFFEF -type string + -x -default "" -type string + -y -default b -type string + -z -default c -type string + -1 -default 1 -type boolean + -2 -default 2 -type integer + -3 -default 3 -type integer + -join -type none -multiple 1 + }] + } proc test1_punkargs_by_id {args} { set argd [punk::args::parse $args withid ::argparsingtest::test1_punkargs_by_id] return [tcl::dict::get $argd opts] } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::argparsingtest::test1_punkargs_parsecache + @cmd -name test1_punkargs_parsecache -summary "punk::args withid with parse cache" -help "Accepts 10 keyed options plus -join. Uses withid and -cache 1 for repeated parse reuse." + @opts -anyopts 0 + -return -default string -type string + -frametype -default \uFFEF -type string + -show_edge -default \uFFEF -type string + -show_seps -default \uFFEF -type string + -x -default "" -type string + -y -default b -type string + -z -default c -type string + -1 -default 1 -type boolean + -2 -default 2 -type integer + -3 -default 3 -type integer + -join -type none -multiple 1 + }] + } proc test1_punkargs_parsecache {args} { set argd [punk::args::parse $args -cache 1 withid ::argparsingtest::test1_punkargs_by_id] return [tcl::dict::get $argd opts] } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::argparsingtest::test1_punkargs_validate_ansistripped + @cmd -name test1_punkargs_validate_ansistripped -summary "punk::args with ansistripped validation" -help "Accepts 10 keyed options plus -join. Uses withdef and -validate_ansistripped on typed opts." + @opts -anyopts 0 + -return -default string -type string + -frametype -default \uFFEF -type string + -show_edge -default \uFFEF -type string + -show_seps -default \uFFEF -type string + -x -default "" -type string + -y -default b -type string + -z -default c -type string + -1 -default 1 -type boolean + -2 -default 2 -type integer + -3 -default 3 -type integer + -join -type none -multiple 1 + }] + } proc test1_punkargs_validate_ansistripped {args} { set argd [punk::args::parse $args withdef { @id -id ::argparsingtest::test1_punkargs_validate_ansistripped @@ -368,6 +577,24 @@ namespace eval argparsingtest { package require opt variable optlist + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::argparsingtest::test1_opt + @cmd -name test1_opt -summary "tcllib opt-based arg parsing" -help "Accepts 10 keyed options plus -join. Uses tcl::OptProc for declaration and parsing." + @opts -anyopts 0 + -return -default string -type string + -frametype -default \uFFEF -type string + -show_edge -default \uFFEF -type string + -show_seps -default \uFFEF -type string + -x -default "" -type string + -y -default b -type string + -z -default c -type string + -1 -default 1 -type boolean + -2 -default 2 -type integer + -3 -default 3 -type integer + -join -type none -multiple 1 + }] + } tcl::OptProc test1_opt { {-return string "return type"} {-frametype \uFFEF "type of frame"} @@ -390,6 +617,24 @@ namespace eval argparsingtest { package require cmdline #cmdline::getoptions is much faster than typedGetoptions + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::argparsingtest::test1_cmdline_untyped + @cmd -name test1_cmdline_untyped -summary "cmdline getoptions untyped" -help "Accepts 10 keyed options plus -join. Uses cmdline::getoptions (untyped, faster)." + @opts -anyopts 0 + -return -default string -type string + -frametype -default \uFFEF -type string + -show_edge -default \uFFEF -type string + -show_seps -default \uFFEF -type string + -x -default "" -type string + -y -default b -type string + -z -default c -type string + -1 -default 1 -type boolean + -2 -default 2 -type integer + -3 -default 3 -type integer + -join -type none -multiple 1 + }] + } proc test1_cmdline_untyped {args} { set cmdlineopts_untyped { {return.arg "string" "return val"} @@ -408,6 +653,24 @@ namespace eval argparsingtest { set usage "usage etc" return [::cmdline::getoptions args $cmdlineopts_untyped $usage] } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::argparsingtest::test1_cmdline_typed + @cmd -name test1_cmdline_typed -summary "cmdline typedGetoptions typed" -help "Accepts 10 keyed options plus -join. Uses cmdline::typedGetoptions with typed specs." + @opts -anyopts 0 + -return -default string -type string + -frametype -default \uFFEF -type string + -show_edge -default \uFFEF -type string + -show_seps -default \uFFEF -type string + -x -default "" -type string + -y -default b -type string + -z -default c -type string + -1 -default 1 -type boolean + -2 -default 2 -type integer + -3 -default 3 -type integer + -join -type none -multiple 1 + }] + } proc test1_cmdline_typed {args} { set cmdlineopts_typed { {return.arg "string" "return val"} @@ -427,6 +690,16 @@ namespace eval argparsingtest { return [::cmdline::typedGetoptions args $cmdlineopts_typed $usage] } + # Upstream argp 0.2 bug: argp::registerArgs (line 34) strips the leading + # '::' from [namespace current] before building the caller key, but + # argp::parseArgs (line 136) takes the raw [info level -1] command name + # with NO leading-'::' stripping. So a proc invoked as '::argparsingtest::test1_argp' + # is cmangled to '_argparsingtest_test1_argp' (spurious leading underscore + # from string map {:: _}), which does not match the registration key + # 'argparsingtest_test1_argp'. Only calling as 'argparsingtest::test1_argp' + # (no leading ::) happens to match. The timeit harness works around this + # by calling parsers as 'argparsingtest::' without the leading '::'. + # See: src/modules/argp-0.2.tm:34 (registerArgs) vs :136 (parseArgs). catch { package require argp argp::registerArgs test1_argp { @@ -442,12 +715,48 @@ namespace eval argparsingtest { { -3 integer 3 } } } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::argparsingtest::test1_argp + @cmd -name test1_argp -summary "argp package arg parsing" -help "Accepts 10 keyed options plus -join. Uses argp::parseArgs for parsing." + @opts -anyopts 0 + -return -default string -type string + -frametype -default \uFFEF -type string + -show_edge -default \uFFEF -type string + -show_seps -default \uFFEF -type string + -x -default "" -type string + -y -default b -type string + -z -default c -type string + -1 -default 1 -type boolean + -2 -default 2 -type integer + -3 -default 3 -type integer + -join -type none -multiple 1 + }] + } proc test1_argp {args} { argp::parseArgs opts return [array get opts] } package require tepam + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::argparsingtest::test1_tepam + @cmd -name test1_tepam -summary "tepam procedure arg parsing" -help "Accepts 10 keyed options plus -join. Uses tepam::procedure for declaration and parsing." + @opts -anyopts 0 + -return -default string -type string + -frametype -default \uFFEF -type string + -show_edge -default \uFFEF -type string + -show_seps -default \uFFEF -type string + -x -default "" -type string + -y -default b -type string + -z -default c -type string + -1 -default 1 -type boolean + -2 -default 2 -type integer + -3 -default 3 -type integer + -join -type none -multiple 1 + }] + } tepam::procedure {test1_tepam} { -args { {-return -type string -default string} @@ -467,6 +776,20 @@ namespace eval argparsingtest { } #multiline values use first line of each record to determine amount of indent to trim + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::argparsingtest::test_multiline + @cmd -name test_multiline -summary "multiline default value handling test" -help "Tests punk::args multiline default indentation using subst." + @opts -anyopts 0 + -template1 -type string + -template2 -type string + -template3 -type string + -template3b -type string + -template4 -type string + -template5 -type string + -flag -type boolean -default 0 + }] + } proc test_multiline {args} { set t3 [textblock::frame t3] set argd [punk::args::parse $args withdef [subst { @@ -498,6 +821,20 @@ namespace eval argparsingtest { }]] return $argd } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::argparsingtest::test_multiline2 + @cmd -name test_multiline2 -summary "multiline default value handling test 2" -help "Tests punk::args multiline default indentation without subst." + @opts -anyopts 0 + -template1 -type string + -template2 -type string + -template3 -type string + -template3b -type string + -template4 -type string + -template5 -type string + -flag -type boolean -default 0 + }] + } proc test_multiline2 {args} { set t3 [textblock::frame t3] set argd [punk::args::parse $args withdef { @@ -546,6 +883,594 @@ namespace eval argparsingtest { + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::argparsingtest::discover_parsers + @cmd -name discover_parsers\ + -summary "Discover available argument parsers"\ + -help\ + "Returns a dict of parser proc names to their load status. + + Each key is a parser proc name. Values are one of: + loaded - proc callable; timed by default + not_loaded - backing package absent; proc must not be called + not_wrappable - optional package present but no timing wrapper shipped" + }] + } + proc discover_parsers {} { + # discover_parsers - return dict of parser proc names to load status + set result {} + + # Always-loaded set: backed by unconditional package requires or no require + foreach pname { + test1_ni + test1_switchmerge + test1_switch + test1_switch_nsvar + test1_switch2 + test1_prefix + test1_prefix2 + test1_punkargs + test1_punkargs_any + test1_punkargs_by_id + test1_punkargs_parsecache + test1_punkargs_validate_ansistripped + test1_opt + test1_cmdline_untyped + test1_cmdline_typed + test1_tepam + } { + dict set result $pname loaded + } + + # argp: proc defined unconditionally but registration guarded by catch at module load; + # use package present to check whether the load-time require succeeded (no side effects) + if {[catch {package present argp}]} { + dict set result test1_argp not_loaded + } else { + dict set result test1_argp loaded + } + + # Optional externals: probe with package require; no timing wrappers shipped for these four + foreach {pname pkg} { + test1_getopt getopt + test1_parse_args parse_args + test1_argparse argparse + test1_cmdr cmdr + } { + if {[catch {package require $pkg}]} { + dict set result $pname not_loaded + } else { + dict set result $pname not_wrappable + } + } + + return $result + } + + punk::args::define { + @id -id ::argparsingtest::timeit + @cmd -name timeit\ + -summary "Time argument parser performance"\ + -help\ + "Runs rough timing comparisons across argument parsers. + + Returns a dict mapping each parser proc name to timing results. + Each value is a sub-dict with keys: + us_per_call - mean microseconds per call + calls_per_sec - mean calls per second + iterations - iteration count used + warmup - warmup count used + Parsers that error during timing return {error } instead." + @opts -anyopts 0 + -iterations -default 1000 -type integer -help\ + "Number of timed invocations per parser." + -warmup -default 1 -type integer -help\ + "Number of untimed warmup invocations before timing starts." + -parsers -default {} -type list -help\ + "List of parser proc names to time. Empty (default) times + all discovered loaded parsers." + -args -default {-return object -x hello -y world -1 1 -2 2 -3 3} -type list -help\ + "Argument vector passed to each parser proc during timing." + } + proc timeit {args} { + # timeit - time argument parser performance, returns dict of {parser -> timing_info} + set argd [punk::args::parse $args withid ::argparsingtest::timeit] + set iterations [dict get $argd opts -iterations] + set warmup [dict get $argd opts -warmup] + set parsers [dict get $argd opts -parsers] + set argvec [dict get $argd opts -args] + + if {[llength $parsers] == 0} { + set discovered [discover_parsers] + set parsers {} + foreach {pname status} $discovered { + if {$status eq "loaded"} { + lappend parsers $pname + } + } + } + + set result {} + foreach pname $parsers { + set had_error 0 + set err_msg {} + + # Use namespace-qualified name (without leading ::) so argp::parseArgs + # (which uses info level -1 to identify the caller) can match the + # registration stored under argparsingtest::. Calling unqualified + # breaks argp scoping; calling with leading :: also breaks it because + # string map {:: _} adds a spurious leading underscore. + set fqname argparsingtest::$pname + + for {set i 0} {$i < $warmup} {incr i} { + try { + $fqname {*}$argvec + } on error {err_result _err_opts} { + set had_error 1 + set err_msg $err_result + break + } + } + if {$had_error} { + dict set result $pname [list error $err_msg] + continue + } + + set start [clock microseconds] + for {set i 0} {$i < $iterations} {incr i} { + try { + $fqname {*}$argvec + } on error {err_result _err_opts} { + set had_error 1 + set err_msg $err_result + break + } + } + set end [clock microseconds] + + if {$had_error} { + dict set result $pname [list error $err_msg] + continue + } + + set us_per_call [expr {double($end - $start) / $iterations}] + set calls_per_sec [expr {1000000.0 / $us_per_call}] + set timing {} + dict set timing us_per_call $us_per_call + dict set timing calls_per_sec $calls_per_sec + dict set timing iterations $iterations + dict set timing warmup $warmup + dict set result $pname $timing + } + return $result + } + + # Per-library warm-up scripts for first_call's 'warm' timing mode. + # Keyed by parser proc name; absent key = hand-rolled parser with no + # backing library (nothing to pre-compile). + # Each script exercises the parser's backing library through sacrificial + # definitions/procs so the library's internals are byte-compiled before + # the timed first call. Warm-ups must never touch the definition or + # registration of the proc under test - resolving those is legitimately + # part of that proc's first-call cost. + variable library_warmups + set library_warmups [dict create] + + # punk::args-backed parsers share one warm-up covering the withid, withdef + # and -cache 1 paths plus the option types/features the test1_punkargs* + # variants use (string/integer/boolean/none types, -multiple, -choices, + # -validate_ansistripped). + set punkargs_warmup { + punk::args::define { + @id -id ::argparsingtest::libwarmup + @cmd -name libwarmup -help "sacrificial definition for punk::args warm-up" + @opts -anyopts 0 + -wstr -default a -type string -choices {a x} + -wint -default 1 -type integer -validate_ansistripped true + -wbool -default 0 -type boolean + -wsolo -type none -multiple 1 + @values + } + punk::args::parse {-wstr x -wint 2 -wbool 1 -wsolo} withid ::argparsingtest::libwarmup + punk::args::parse {-wstr x} -cache 1 withid ::argparsingtest::libwarmup + punk::args::parse {-wstr x} withdef { + @id -id ::argparsingtest::libwarmup_withdef + @opts -anyopts 0 + -wstr -default a -type string + } + } + foreach pname { + test1_punkargs + test1_punkargs_any + test1_punkargs_by_id + test1_punkargs_parsecache + test1_punkargs_validate_ansistripped + } { + dict set library_warmups $pname $punkargs_warmup + } + unset pname punkargs_warmup + + dict set library_warmups test1_opt { + tcl::OptProc ::argparsingtest::libwarmup_opt { + {-w 0 "warm-up option"} + } { + return [info locals] + } + ::argparsingtest::libwarmup_opt -w 1 + } + dict set library_warmups test1_cmdline_untyped { + set libwarmup_args {-w 1} + cmdline::getoptions libwarmup_args { + {w.arg 0 "warm-up option"} + } "usage" + } + dict set library_warmups test1_cmdline_typed { + set libwarmup_args {-w 1} + cmdline::typedGetoptions libwarmup_args { + {w.integer 0 "warm-up option"} + } "usage" + } + dict set library_warmups test1_tepam { + tepam::procedure libwarmup_tepam { + -args { + {-w -type integer -default 0} + } + } { + return $w + } + libwarmup_tepam -w 1 + } + # argp caller-key mangling (see the test1_argp registration site): register + # inside the argparsingtest namespace and call without a leading '::' so + # registerArgs' key matches parseArgs' caller lookup. + dict set library_warmups test1_argp { + namespace eval ::argparsingtest { + argp::registerArgs libwarmup_argp { + {-w integer 0} + } + proc libwarmup_argp {args} { + argp::parseArgs opts + return [array get opts] + } + } + argparsingtest::libwarmup_argp -w 1 + } + + punk::args::define { + @id -id ::argparsingtest::first_call + @cmd -name first_call\ + -summary "Time cold and warm first-call cost of each argument parser"\ + -help\ + "Creates fresh child interpreters for each parser and times + the first invocation after loading the argparsingtest module. + Child interps load the parent's exact package versions of + argparsingtest, punk::args and (when present) punk::lib so the + module timed is the one under test rather than any older + stable copy visible on the module paths. + + Each parser is timed twice, in separate child interps: + cold - first call immediately after package load. Includes + byte-compilation of the parser proc body and of any + backing-library procs it invokes. + warm - the parser's backing library is first exercised via a + sacrificial definition/proc distinct from the one under + test, so library internals are already byte-compiled + when the timed call runs. This isolates the per-proc + first-use cost (definition resolution, registration + lookup, proc body compile). Hand-rolled parsers have no + backing library to warm; their warm figure is simply a + second cold measurement. + + Returns a dict mapping each parser name to a sub-dict with keys + cold and warm. Each value is that run's first-call microseconds + (float), or {error } if the run fails in the child + interp." + @opts -anyopts 0 + -parsers -default {} -type list -help\ + "List of parser proc names to time. Empty (default) times + all discovered loaded parsers." + } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::argparsingtest::first_call + @cmd -name first_call\ + -summary "Time cold and warm first-call cost of each argument parser"\ + -help\ + "Creates fresh child interpreters for each parser and times + the first invocation after loading the argparsingtest module. + Child interps load the parent's exact package versions of + argparsingtest, punk::args and (when present) punk::lib so the + module timed is the one under test rather than any older + stable copy visible on the module paths. + + Each parser is timed twice, in separate child interps: + cold - first call immediately after package load. Includes + byte-compilation of the parser proc body and of any + backing-library procs it invokes. + warm - the parser's backing library is first exercised via a + sacrificial definition/proc distinct from the one under + test, so library internals are already byte-compiled + when the timed call runs. This isolates the per-proc + first-use cost (definition resolution, registration + lookup, proc body compile). Hand-rolled parsers have no + backing library to warm; their warm figure is simply a + second cold measurement. + + Returns a dict mapping each parser name to a sub-dict with keys + cold and warm. Each value is that run's first-call microseconds + (float), or {error } if the run fails in the child + interp." + @opts -anyopts 0 + -parsers -default {} -type list -help\ + "List of parser proc names to time. Empty (default) times + all discovered loaded parsers." + }] + } + proc first_call {args} { + # first_call - time cold and warm first-call cost of each parser in fresh child interps + set argd [punk::args::parse $args withid ::argparsingtest::first_call] + set parsers [dict get $argd opts -parsers] + + variable library_warmups + + set argvec {-return object -x hello -y world -1 1 -2 2 -3 3} + + if {[llength $parsers] == 0} { + set discovered [discover_parsers] + set parsers {} + foreach {pname status} $discovered { + if {$status eq "loaded"} { + lappend parsers $pname + } + } + } + + # Capture parent interp's module paths and auto_path for transfer to children + set tm_paths [tcl::tm::list] + set ap $::auto_path + + # Pin the child's package requires to the versions loaded in the parent. + # Plain 'package require' prefers stable versions, so a dev/alpha module + # loaded in the parent would otherwise be shadowed in the child by any + # older stable copy visible on the module paths - the child would then + # time a different module than the one under test. punk::lib is included + # (when the parent has it) because it provides the lpop compat shim that + # punk::args::parse needs under Tcl 8.6; require order matters - pin + # punk::args before punk::lib/argparsingtest so their own plain + # 'package require punk::args' calls resolve to the pinned version. + set pinned_requires "" + foreach pkg {punk::args punk::lib argparsingtest} { + if {![catch {package present $pkg} ver]} { + append pinned_requires "package require -exact [list $pkg] [list $ver]\n" + } + } + + set result {} + foreach pname $parsers { + set timings {} + foreach mode {cold warm} { + if {$mode eq "warm" && [dict exists $library_warmups $pname]} { + set warmup [dict get $library_warmups $pname] + } else { + #cold run - or warm run for a parser with no backing library (nothing to pre-compile) + set warmup "" + } + set child [interp create] + try { + # Clear child's tm list and auto_path (which come from the + # environment) then set them to match the parent interp so + # module resolution is identical. + set child_tm [interp eval $child {tcl::tm::list}] + if {[llength $child_tm]} { + interp eval $child [list tcl::tm::path remove {*}$child_tm] + } + interp eval $child [list set ::auto_path $ap] + if {[llength $tm_paths]} { + interp eval $child [list tcl::tm::path add {*}$tm_paths] + } + + # Load the module (pinned to parent's versions), run any + # library warm-up, then time the FIRST call to this parser. + # Build a script with the requires, warmup, pname and argvec + # substituted into place, using expand-style per AGENTS.md. + set script [string cat\ + $pinned_requires\ + $warmup {*}{ + "\nset start \[clock microseconds]\n" + } "argparsingtest::$pname $argvec\n" {*}{ + "set end \[clock microseconds]\n" + "return \[expr {double(\$end - \$start)}]" + }] + if {[catch {interp eval $child $script} us_val us_opts]} { + dict set timings $mode [list error $us_val] + } else { + dict set timings $mode $us_val + } + } on error {err opts} { + dict set timings $mode [list error $err] + } finally { + interp delete $child + } + } + dict set result $pname $timings + } + return $result + } + + punk::args::define { + @id -id ::argparsingtest::compare + @cmd -name compare\ + -summary "Compare argument parser performance"\ + -help\ + "Runs timing comparisons and outputs results as table, dict, or json. + + Returns a formatted comparison of all loaded argument parsers. + Rows are sorted fastest-first (ascending us_per_call). + - table: human-readable matrix sorted by us_per_call ascending + (first_cold/first_warm columns are first_call timings) + - dict: {results first_call not_loaded } + first_call values are {cold warm } sub-dicts (see first_call) + - json: JSON object with results, first_call, and not_loaded keys" + @opts -anyopts 0 + -format -default table -type string -choices {table dict json} -help\ + "Output format: table (default), dict, or json." + -iterations -default 1000 -type integer -help\ + "Number of timed invocations per parser." + -warmup -default 1 -type integer -help\ + "Number of untimed warmup invocations before timing starts." + -parsers -default {} -type list -help\ + "List of parser proc names to time. Empty (default) times + all discovered loaded parsers." + -args -default {-return object -x hello -y world -1 1 -2 2 -3 3} -type list -help\ + "Argument vector passed to each parser proc during timing." + } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::argparsingtest::compare + @cmd -name compare\ + -summary "Compare argument parser performance"\ + -help\ + "Runs timing comparisons and outputs results as table, dict, or json. + + Returns a formatted comparison of all loaded argument parsers. + Rows are sorted fastest-first (ascending us_per_call). + - table: human-readable matrix sorted by us_per_call ascending + (first_cold/first_warm columns are first_call timings) + - dict: {results first_call not_loaded } + first_call values are {cold warm } sub-dicts (see first_call) + - json: JSON object with results, first_call, and not_loaded keys" + @opts -anyopts 0 + -format -default table -type string -choices {table dict json} -help\ + "Output format: table (default), dict, or json." + -iterations -default 1000 -type integer -help\ + "Number of timed invocations per parser." + -warmup -default 1 -type integer -help\ + "Number of untimed warmup invocations before timing starts." + -parsers -default {} -type list -help\ + "List of parser proc names to time. Empty (default) times + all discovered loaded parsers." + -args -default {-return object -x hello -y world -1 1 -2 2 -3 3} -type list -help\ + "Argument vector passed to each parser proc during timing." + }] + } + proc compare {args} { + # compare - compare argument parser performance, returns formatted table/dict/json + set argd [punk::args::parse $args withid ::argparsingtest::compare] + set fmt [dict get $argd opts -format] + set iterations [dict get $argd opts -iterations] + set warmup [dict get $argd opts -warmup] + set parsers [dict get $argd opts -parsers] + set argvec [dict get $argd opts -args] + + set timeit_args [list -iterations $iterations -warmup $warmup -args $argvec] + if {[llength $parsers] > 0} { + lappend timeit_args -parsers $parsers + } + set timeit_dict [timeit {*}$timeit_args] + + set first_call_args {} + if {[llength $parsers] > 0} { + set first_call_args [list -parsers $parsers] + } + set first_call_dict [first_call {*}$first_call_args] + + set discovered [discover_parsers] + set not_loaded_list {} + foreach {pname status} $discovered { + if {$status eq "not_loaded" || $status eq "not_wrappable"} { + lappend not_loaded_list $pname + } + } + + switch -- $fmt { + table { + set colwidth 6 + foreach nm [dict keys $timeit_dict] { + set l [string length $nm] + if {$l > $colwidth} { set colwidth $l } + } + set rows {} + set error_names {} + foreach {pname timing} $timeit_dict { + if {[dict exists $timing error]} { + lappend error_names $pname + } else { + set fcold "" + set fwarm "" + if {[dict exists $first_call_dict $pname]} { + set fdict [dict get $first_call_dict $pname] + foreach {mode varname} {cold fcold warm fwarm} { + if {[dict exists $fdict $mode]} { + set fval [dict get $fdict $mode] + if {[llength $fval] == 2 && [lindex $fval 0] eq "error"} { + set $varname "err" + } else { + set $varname [format %.2f $fval] + } + } + } + } + lappend rows [list [dict get $timing us_per_call] $pname [dict get $timing calls_per_sec] $fcold $fwarm [dict get $timing iterations]] + } + } + set rows [lsort -real -index 0 $rows] + set lines {} + lappend lines [format "%-${colwidth}s %12s %14s %10s %10s %10s" Parser us/call calls/sec first_cold first_warm iterations] + lappend lines [format "%-${colwidth}s %12s %14s %10s %10s %10s" [string repeat - $colwidth] [string repeat - 12] [string repeat - 14] [string repeat - 10] [string repeat - 10] [string repeat - 10]] + foreach row $rows { + lassign $row upc pname cps fcold fwarm itr + lappend lines [format "%-${colwidth}s %12.2f %14.0f %10s %10s %10d" $pname $upc $cps $fcold $fwarm $itr] + } + if {[llength $not_loaded_list] > 0} { + lappend lines "not loaded: [join $not_loaded_list {, }]" + } else { + lappend lines "not loaded: (none)" + } + if {[llength $error_names] > 0} { + lappend lines "errors: [join $error_names {, }]" + } + return [join $lines \n] + } + dict { + return [dict create results $timeit_dict first_call $first_call_dict not_loaded $not_loaded_list] + } + json { + package require json::write + set timing_jsons [dict map {k v} $timeit_dict { + if {[dict exists $v error]} { + json::write object error [json::write string [dict get $v error]] + } else { + set jv_upc [json::write string [dict get $v us_per_call]] + set jv_cps [json::write string [dict get $v calls_per_sec]] + set jv_itr [json::write string [dict get $v iterations]] + set jv_wu [json::write string [dict get $v warmup]] + json::write object us_per_call $jv_upc calls_per_sec $jv_cps iterations $jv_itr warmup $jv_wu + } + }] + set results_json [json::write object {*}$timing_jsons] + set not_loaded_json [json::write array-strings {*}$not_loaded_list] + set fc_pairs {} + foreach {pname fdict} $first_call_dict { + set mode_pairs {} + foreach mode {cold warm} { + if {[dict exists $fdict $mode]} { + set fval [dict get $fdict $mode] + if {[llength $fval] == 2 && [lindex $fval 0] eq "error"} { + lappend mode_pairs $mode [json::write object error [json::write string [lindex $fval 1]]] + } else { + lappend mode_pairs $mode [json::write string $fval] + } + } + } + lappend fc_pairs $pname [json::write object {*}$mode_pairs] + } + set first_call_json [json::write object {*}$fc_pairs] + return [json::write object results $results_json first_call $first_call_json not_loaded $not_loaded_json] + } + } + } + #*** !doctools #[list_end] [comment {--- end definitions namespace argparsingtest ---}] } @@ -591,6 +1516,10 @@ namespace eval argparsingtest::system { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval ::punk::args::register { + lappend ::punk::args::register::NAMESPACES ::argparsingtest ::argparsingtest::lib +} + ## Ready package provide argparsingtest [namespace eval argparsingtest { variable pkg argparsingtest diff --git a/src/modules/argparsingtest-buildversion.txt b/src/modules/argparsingtest-buildversion.txt index f47d01c8..c764f805 100644 --- a/src/modules/argparsingtest-buildversion.txt +++ b/src/modules/argparsingtest-buildversion.txt @@ -1,3 +1,6 @@ -0.1.0 +0.2.0 #First line must be a semantic version number #all other lines are ignored. +#0.2.0 - added timeit/compare/discover_parsers procs for rough parser timing comparison; PUNKARGS argdoc blocks added to all procs +#0.2.0 - fixed timeit to call parsers with namespace-qualified name (workaround for upstream argp 0.2 caller-normalisation bug); noted the bug at the test1_argp registration site +#0.2.0 - first_call now times cold AND warm first calls per parser (warm = backing library pre-compiled via per-library sacrificial warm-up scripts in library_warmups); replaces the punk::args-only 'punk::args::parse {} withdef {}' warm hack which was unfair to other libraries; return shape now {parser {cold warm }}; compare table gains first_cold/first_warm columns \ No newline at end of file diff --git a/src/tests/modules/argparsingtest/testsuites/argparsingtest/argparsingtest.test b/src/tests/modules/argparsingtest/testsuites/argparsingtest/argparsingtest.test new file mode 100644 index 00000000..63c159f7 --- /dev/null +++ b/src/tests/modules/argparsingtest/testsuites/argparsingtest/argparsingtest.test @@ -0,0 +1,145 @@ + +package require tcltest +package require argparsingtest +package require json + +namespace eval ::testspace { + namespace import ::tcltest::* + + #added 2026-07-17 (agent) - argp is an optional package; its load-time require is guarded by catch in the module + testConstraint argp_loaded [expr {![catch {package present argp}]}] + + #added 2026-07-17 (agent) + test timeit_basic {Test that timeit -iterations 50 returns a dict with expected keys} -body { + set r [argparsingtest::timeit -iterations 50 -parsers {test1_switch}] + set ok 1 + if {![dict exists $r test1_switch]} { set ok 0 } + if {$ok} { + set sub [dict get $r test1_switch] + if {![dict exists $sub us_per_call]} { set ok 0 } + if {$ok && ![string is double -strict [dict get $sub us_per_call]]} { set ok 0 } + if {$ok && [dict get $sub iterations] != 50} { set ok 0 } + } + set ok + } -result 1 + + #added 2026-07-17 (agent) + test compare_table {Test that compare -iterations 20 -format table returns string with Parser header and not loaded footer} -body { + set r [argparsingtest::compare -iterations 20 -format table] + set ok 1 + if {[string first "Parser" $r] < 0} { set ok 0 } + if {$ok && [string first "not loaded:" $r] < 0} { set ok 0 } + set ok + } -result 1 + + #added 2026-07-17 (agent) + test compare_dict {Test that compare -iterations 20 -format dict returns a dict with not_loaded and results keys} -body { + set r [argparsingtest::compare -iterations 20 -format dict] + set ok 1 + if {![dict exists $r not_loaded]} { set ok 0 } + if {$ok && ![dict exists $r results]} { set ok 0 } + set ok + } -result 1 + + #added 2026-07-17 (agent) + test compare_json {Test that compare -iterations 20 -format json returns valid JSON with results and not_loaded keys} -body { + set r [argparsingtest::compare -iterations 20 -format json] + set ok 1 + if {[catch {set d [json::json2dict $r]} _err]} { set ok 0 } + if {$ok && ![dict exists $d results]} { set ok 0 } + if {$ok && ![dict exists $d not_loaded]} { set ok 0 } + set ok + } -result 1 + + #added 2026-07-17 (agent) + test compare_badformat {Test that compare -format bogus raises an error containing choiceviolation} -body { + set caught [catch {argparsingtest::compare -format bogus} err] + set ok 0 + if {$caught && ([string first "choiceviolation" $err] >= 0 || [string first "must be one of" $err] >= 0)} { + set ok 1 + } + set ok + } -result 1 + + #added 2026-07-17 (agent) + test discover_parsers_basic {Test that discover_parsers returns a dict with test1_switch loaded and 21 entries} -body { + set r [argparsingtest::discover_parsers] + set ok 1 + if {![dict exists $r test1_switch]} { set ok 0 } + if {$ok && [dict get $r test1_switch] ne "loaded"} { set ok 0 } + if {$ok && [dict size $r] != 21} { set ok 0 } + set ok + } -result 1 + + #added 2026-07-17 (agent) + test first_call_handrolled {Test that first_call returns cold and warm float timings for a hand-rolled parser} -body { + set r [argparsingtest::first_call -parsers {test1_switch}] + set ok 1 + if {![dict exists $r test1_switch]} { set ok 0 } + if {$ok} { + set sub [dict get $r test1_switch] + foreach mode {cold warm} { + if {![dict exists $sub $mode]} { set ok 0 ; break } + if {![string is double -strict [dict get $sub $mode]]} { set ok 0 ; break } + } + } + set ok + } -result 1 + + #added 2026-07-17 (agent) + test first_call_library_backed {Test that first_call returns cold and warm float timings for library-backed parsers (warm-up scripts must run cleanly)} -body { + set r [argparsingtest::first_call -parsers {test1_punkargs test1_punkargs_by_id test1_opt test1_cmdline_untyped test1_cmdline_typed test1_tepam}] + set ok 1 + foreach {pname sub} $r { + foreach mode {cold warm} { + if {![dict exists $sub $mode]} { set ok "missing $mode for $pname" ; break } + if {![string is double -strict [dict get $sub $mode]]} { set ok "$pname $mode: [dict get $sub $mode]" ; break } + } + if {$ok ne 1} { break } + } + set ok + } -result 1 + + #added 2026-07-17 (agent) + test first_call_argp {Test first_call cold and warm for test1_argp when argp is loaded} -constraints argp_loaded -body { + set r [argparsingtest::first_call -parsers {test1_argp}] + set sub [dict get $r test1_argp] + set ok 1 + foreach mode {cold warm} { + if {![string is double -strict [dict get $sub $mode]]} { set ok "$mode: [dict get $sub $mode]" ; break } + } + set ok + } -result 1 + + #added 2026-07-17 (agent) + test compare_table_first_columns {Test that compare table output has first_cold and first_warm columns} -body { + set r [argparsingtest::compare -iterations 20 -format table -parsers {test1_switch}] + set ok 1 + if {[string first "first_cold" $r] < 0} { set ok 0 } + if {$ok && [string first "first_warm" $r] < 0} { set ok 0 } + set ok + } -result 1 + + #added 2026-07-17 (agent) + test compare_json_first_call_structure {Test that compare json first_call entries are objects with cold and warm keys} -body { + set r [argparsingtest::compare -iterations 20 -format json -parsers {test1_switch}] + set d [json::json2dict $r] + set ok 1 + if {![dict exists $d first_call test1_switch cold]} { set ok 0 } + if {$ok && ![dict exists $d first_call test1_switch warm]} { set ok 0 } + set ok + } -result 1 + + #added 2026-07-17 (agent) + test timeit_nonexistent {Test that a nonexistent parser is recorded as error not re-raised} -body { + set r [argparsingtest::timeit -parsers {nonexistent_proc}] + set ok 1 + if {![dict exists $r nonexistent_proc]} { set ok 0 } + if {$ok} { + set sub [dict get $r nonexistent_proc] + if {![dict exists $sub error]} { set ok 0 } + } + set ok + } -result 1 +} +tcltest::cleanupTests