diff --git a/AGENTS.md b/AGENTS.md index 29edd2b2..a8f5f5fb 100644 --- a/AGENTS.md +++ b/AGENTS.md @@ -92,7 +92,7 @@ When the user requests a durable behavior change, record it here or in the relev - `src/lib_tcl8/` — Tcl 8 specific libraries - `src/lib_tcl9/` — Tcl 9 specific libraries - `src/bootsupport/` — Early-load bootstrap modules (see src/bootsupport/AGENTS.md) - - `src/tests/` — Unit tests for src-hierarchy modules (see src/tests/AGENTS.md) + - `src/tests/` — Source-tree test harness and tests (see src/tests/AGENTS.md) - `src/vfs/` — Virtual file system images for builds (see src/vfs/AGENTS.md) - `src/scriptapps/` — Entry-point scripts for Punk apps (see src/scriptapps/AGENTS.md) - `src/vendormodules/` — Third-party bundled modules (see src/vendormodules/AGENTS.md) diff --git a/src/AGENTS.md b/src/AGENTS.md index c0fc911b..49cbb82b 100644 --- a/src/AGENTS.md +++ b/src/AGENTS.md @@ -91,7 +91,7 @@ Recovery after a wrong path guess: - `lib_tcl8/` — Tcl 8 specific libraries - `lib_tcl9/` — Tcl 9 specific libraries - `bootsupport/` — Early-load bootstrap modules (see bootsupport/AGENTS.md) -- `tests/` — Unit tests for src-hierarchy modules (see tests/AGENTS.md) +- `tests/` — Source-tree test harness and tests (see tests/AGENTS.md) - `vfs/` — Virtual file system images for builds (see vfs/AGENTS.md) - `scriptapps/` — Entry-point scripts for Punk apps (see scriptapps/AGENTS.md) - `vendormodules/` — Third-party bundled modules (see vendormodules/AGENTS.md) diff --git a/src/tests/AGENTS.md b/src/tests/AGENTS.md index 7af5090b..36071455 100644 --- a/src/tests/AGENTS.md +++ b/src/tests/AGENTS.md @@ -1,38 +1,39 @@ -# src/tests — Unit Tests for src-Hierarchy Modules +# src/tests — Source-Tree Test Harness ## Purpose -Unit tests that run against modules in the `src/` source tree, prior to installation. These tests use the `tcltest` package and target the uninstalled module source code. +Top-level test harness and source-tree tests for ShellSpy/Punk. Tests here exercise source files under `src/` before installation or packaging, including module tests, shell behavior tests, and selected Tcl core compatibility tests. ## Ownership -- Owned by the project maintainer; agents should add new tests here when modifying modules but must not delete or silently skip existing failing tests. -- This is the primary test-authoring location for module behavior. Installed-module test packages under `src/modules/test/` are a packaging layer, not the default place to add tests. +- Owned by the project maintainer; agents may update tests here when changing source behavior. +- Do not delete, skip, or weaken existing tests without explicit user direction. +- Keep build-output and installed-package tests outside this tree unless a local child AGENTS.md says otherwise. ## Local Contracts -- Test files use `.tcl` extension and must `package require punk` plus any extra packages explicitly. -- The directory hierarchy under `src/tests/modules/` mirrors namespace paths of the modules being tested. -- Tests run against source modules in the `src/` tree, not installed packages. -- New test files go in `src/tests/modules//tests/` mirroring the module namespace. -- Prefer `try { ... } on error {result options} { ... }` for structured error capture in test bodies. -- Focused verification should mirror production pipelines inside tests using Punk pipeline syntax when that parity matters. -- Test files may commonly use line-continuation backslashes, and existing Tcl expand-syntax structures in tests should not be refactored into line continuations. +- `runtests.tcl` is the primary source-tree test entry point. +- Tests use `tcltest` unless a child AGENTS.md documents a different local harness. +- `runtests.tcl` excludes `AGENTS.md` and `*.tcl` helper files when discovering `.test` files. +- Tests should run against source modules and libraries from `src/`, not installed packages or root-level build outputs. +- Test files must `package require` any extra packages explicitly. ## Work Guidance -- Run a single test: `tclsh src/tests/modules//tests/all.tcl`. -- Run the full suite: `tclsh src/tests/runtests.tcl`. -- On Windows, an alternate full-suite loop is `for /r src\tests %f in (*.tcl) do tclsh %f`. -- When adding a test, mirror the namespace path of the module under test. -- Do not add tests for vendormodules or bootsupport here unless explicitly requested. -- Capture stderr logs for failure triage and include enough context for the failing command or assertion. +- Select an appropriate interpreter, such as `tclsh`, `tclsh90`, or a built Punk executable such as `punk902z`. +- Run the full source-tree suite with ` src/tests/runtests.tcl`. +- Use `-include-paths` with paths relative to `src/tests/`, using forward slashes. +- Use `-tcltestoptions {-match }` for focused single-test runs. +- Capture enough stderr or failure context to identify the failing command or assertion. ## Verification -- `tclsh src/tests//all.tcl` exits cleanly with pass/fail summary. -- `tclsh src/tests/runtests.tcl` passes when broad test coverage is relevant. +- ` src/tests/runtests.tcl` passes when broad source-tree test coverage is relevant. +- Focused checks use ` src/tests/runtests.tcl -include-paths ` and optional file-tail globs. +- Documentation-only changes are verified by reviewing the affected DOX chain and diff. ## Child DOX Index -- `modules/` — Per-namespace test directories mirroring `src/modules/` structure +- `modules/` — Source module test suites mirroring editable module namespaces (see modules/AGENTS.md) +- `core/` — Selected Tcl core compatibility tests for standard Tcl and built Punk executables (see core/AGENTS.md) +- `shell/` — Shell behavior tests and command-line interaction suites (see shell/AGENTS.md) diff --git a/src/tests/core/AGENTS.md b/src/tests/core/AGENTS.md new file mode 100644 index 00000000..81e61ddb --- /dev/null +++ b/src/tests/core/AGENTS.md @@ -0,0 +1,31 @@ +# src/tests/core — Tcl Core Compatibility Tests + +## Purpose + +Selected tests taken from or modeled after Tcl core tests. These tests should produce compatible results under a standard `tclsh` and an appropriate built Punk executable. + +## Ownership + +- Agents may update this subtree when changing compatibility expectations or test harness behavior for core Tcl commands. +- Preserve the intent of upstream Tcl compatibility coverage when editing imported or adapted tests. + +## Local Contracts + +- Tests under this subtree are compatibility tests, not general module behavior tests. +- Keep command behavior expectations explicit enough to compare standard Tcl and built Punk results. +- Avoid mixing source-module feature tests into this subtree; use `src/tests/modules/` instead. + +## Work Guidance + +- Use `src/tests/runtests.tcl` from the repository root for source-tree harness runs. +- Prefer focused `-include-paths core/**` checks when editing only this subtree. +- Document any deliberate divergence from standard Tcl behavior in the nearest relevant test file or child AGENTS.md. + +## Verification + +- ` src/tests/runtests.tcl -include-paths core/**` passes for changes in this subtree. +- Compare results with standard `tclsh` and the target Punk executable when compatibility behavior is the subject of the change. + +## Child DOX Index + +- `tcl/testsuites/tests/` — Imported/adapted Tcl core test files (see tcl/testsuites/tests/AGENTS.md) diff --git a/src/tests/core/tcl/testsuites/tests/AGENTS.md b/src/tests/core/tcl/testsuites/tests/AGENTS.md new file mode 100644 index 00000000..39ed1486 --- /dev/null +++ b/src/tests/core/tcl/testsuites/tests/AGENTS.md @@ -0,0 +1,27 @@ +# src/tests/core/tcl/testsuites/tests — Tcl Core Test Files + +## Purpose + +A selection of unit tests taken from or modeled after the Tcl core distribution. These tests, designed for a standard `tclsh`, should produce the same results for a suitable built Punk executable. + +## Ownership + +- Preserve Tcl core compatibility intent when editing tests in this directory. +- Keep broader core-test rules in `src/tests/core/AGENTS.md`. + +## Local Contracts + +- Tests here target Tcl command compatibility, not general Punk module behavior. +- Deliberate Punk divergences from standard Tcl behavior must be documented near the affected test. + +## Work Guidance + +- Use focused runs through `src/tests/runtests.tcl` with `-include-paths core/tcl/testsuites/tests/**`. + +## Verification + +- ` src/tests/runtests.tcl -include-paths core/tcl/testsuites/tests/**` passes for changes in this directory. + +## Child DOX Index + + diff --git a/src/tests/core/tcl/testsuites/tests/exec.test b/src/tests/core/tcl/testsuites/tests/exec.test new file mode 100644 index 00000000..d2f42af3 --- /dev/null +++ b/src/tests/core/tcl/testsuites/tests/exec.test @@ -0,0 +1,758 @@ +# Commands covered: exec +# +# This file contains a collection of tests for one or more of the Tcl built-in +# commands. Sourcing this file into Tcl runs the tests and generates output +# for errors. No output means no errors were found. +# +# Copyright © 1991-1994 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# There is no point in running Valgrind on cases where [exec] forks but then +# fails and the child process doesn't go through full cleanup. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} +source [file join [file dirname [info script]] tcltests.tcl] + +# Some skips when running in a macOS CI environment +testConstraint noosxCI [expr {![info exists ::env(MAC_CI)]}] + +unset -nocomplain path + +# Utilities that are like Bourne shell stalwarts, but cross-platform. +set path(echo) [makeFile { + puts -nonewline [lindex $argv 0] + foreach str [lrange $argv 1 end] { + puts -nonewline " $str" + } + puts {} + exit +} echo] +set path(echo2) [makeFile { + puts stdout [join $argv] + puts stderr [lindex $argv 1] + exit +} echo2] +set path(cat) [makeFile { + if {$argv eq ""} { + set argv - + } + fconfigure stdout -translation binary + foreach name $argv { + if {$name eq "-"} { + set f stdin + } elseif {[catch {open $name r} f] != 0} { + puts stderr $f + continue + } + fconfigure $f -translation binary + while {[eof $f] == 0} { + puts -nonewline [read $f] + } + if {$f ne "stdin"} { + close $f + } + } + exit +} cat] +set path(wc) [makeFile { + set data [read stdin] + set lines [regsub -all "\n" $data {} dummy] + set words [regsub -all "\[^ \t\n]+" $data {} dummy] + set chars [string length $data] + puts [format "%8.d%8.d%8.d" $lines $words $chars] + exit +} wc] +set path(sh) [makeFile { + if {[lindex $argv 0] ne "-c"} { + error "sh: unexpected arguments $argv" + } + set cmd [lindex $argv 1] + lappend cmd ";" + set newcmd {} + foreach arg $cmd { + if {$arg eq ";"} { + exec >@stdout 2>@stderr [info nameofexecutable] {*}$newcmd + set newcmd {} + continue + } + if {$arg eq "1>&2"} { + set arg >@stderr + } + lappend newcmd $arg + } + exit +} sh] +set path(sh2) [makeFile { + if {[lindex $argv 0] ne "-c"} { + error "sh: unexpected arguments $argv" + } + set cmd [lindex $argv 1] + lappend cmd ";" + set newcmd {} + foreach arg $cmd { + if {$arg eq ";"} { + exec -ignorestderr >@stdout [info nameofexecutable] {*}$newcmd + set newcmd {} + continue + } + lappend newcmd $arg + } + exit +} sh2] +set path(sleep) [makeFile { + after [expr {$argv*1000}] + exit +} sleep] +set path(exit) [makeFile { + exit $argv +} exit] + +proc readfile filename { + set f [open $filename] + set d [read $f] + close $f + return [string trimright $d \n] +} + +# ---------------------------------------------------------------------- +# Basic operations. + +test exec-1.1 {basic exec operation} {exec} { + exec [interpreter] $path(echo) a b c +} "a b c" +test exec-1.2 {pipelining} {exec stdio} { + exec [interpreter] $path(echo) a b c d | [interpreter] $path(cat) | [interpreter] $path(cat) +} "a b c d" +test exec-1.3 {pipelining} {exec stdio} { + set a [exec [interpreter] $path(echo) a b c d | [interpreter] $path(cat) | [interpreter] $path(wc)] + list [scan $a "%d %d %d" b c d] $b $c +} {3 1 4} +set arg {12345678901234567890123456789012345678901234567890} +set arg "$arg$arg$arg$arg$arg$arg" +test exec-1.4 {long command lines} {exec} { + exec [interpreter] $path(echo) $arg +} $arg +set arg {} + +# I/O redirection: input from Tcl command. + +test exec-2.1 {redirecting input from immediate source} {exec stdio} { + exec [interpreter] $path(cat) << "Sample text" +} {Sample text} +test exec-2.2 {redirecting input from immediate source} {exec stdio} { + exec << "Sample text" [interpreter] $path(cat) | [interpreter] $path(cat) +} {Sample text} +test exec-2.3 {redirecting input from immediate source} {exec stdio} { + exec [interpreter] $path(cat) << "Sample text" | [interpreter] $path(cat) +} {Sample text} +test exec-2.4 {redirecting input from immediate source} {exec stdio} { + exec [interpreter] $path(cat) | [interpreter] $path(cat) << "Sample text" +} {Sample text} +test exec-2.5 {redirecting input from immediate source} {exec} { + exec [interpreter] $path(cat) "< external conversion did not occur + # before writing out the temp file. + quotenonascii [exec [interpreter] $path(cat) << "\xE9\xE0\xFC\xF1"] +} -cleanup { + encoding system $sysenc + rename quotenonascii {} +} -result {\xE9\xE0\xFC\xF1} + +# I/O redirection: output to file. + +set path(gorp.file) [makeFile {} gorp.file] +file delete $path(gorp.file) + +test exec-3.1 {redirecting output to file} {exec} { + exec [interpreter] $path(echo) "Some simple words" > $path(gorp.file) + exec [interpreter] $path(cat) $path(gorp.file) +} "Some simple words" +test exec-3.2 {redirecting output to file} {exec stdio} { + exec [interpreter] $path(echo) "More simple words" | >$path(gorp.file) [interpreter] $path(cat) | [interpreter] $path(cat) + exec [interpreter] $path(cat) $path(gorp.file) +} "More simple words" +test exec-3.3 {redirecting output to file} {exec stdio} { + exec > $path(gorp.file) [interpreter] $path(echo) "Different simple words" | [interpreter] $path(cat) | [interpreter] $path(cat) + exec [interpreter] $path(cat) $path(gorp.file) +} "Different simple words" +test exec-3.4 {redirecting output to file} {exec} { + exec [interpreter] $path(echo) "Some simple words" >$path(gorp.file) + exec [interpreter] $path(cat) $path(gorp.file) +} "Some simple words" +test exec-3.5 {redirecting output to file} {exec} { + exec [interpreter] $path(echo) "First line" >$path(gorp.file) + exec [interpreter] $path(echo) "Second line" >> $path(gorp.file) + exec [interpreter] $path(cat) $path(gorp.file) +} "First line\nSecond line" +test exec-3.6 {redirecting output to file} {exec} { + exec [interpreter] $path(echo) "First line" >$path(gorp.file) + exec [interpreter] $path(echo) "Second line" >>$path(gorp.file) + exec [interpreter] $path(cat) $path(gorp.file) +} "First line\nSecond line" +test exec-3.7 {redirecting output to file} {exec} { + set f [open $path(gorp.file) w] + puts $f "Line 1" + flush $f + exec [interpreter] $path(echo) "More text" >@ $f + exec [interpreter] $path(echo) >@$f "Even more" + puts $f "Line 3" + close $f + exec [interpreter] $path(cat) $path(gorp.file) +} "Line 1\nMore text\nEven more\nLine 3" + +# I/O redirection: output and stderr to file. + +file delete $path(gorp.file) + +test exec-4.1 {redirecting output and stderr to file} {exec} { + exec [interpreter] $path(echo) "test output" >& $path(gorp.file) + exec [interpreter] $path(cat) $path(gorp.file) +} "test output" +test exec-4.2 {redirecting output and stderr to file} {exec} { + list [exec [interpreter] $path(sh) -c "\"$path(echo)\" foo bar 1>&2" >&$path(gorp.file)] \ + [exec [interpreter] $path(cat) $path(gorp.file)] +} {{} {foo bar}} +test exec-4.3 {redirecting output and stderr to file} {exec} { + exec [interpreter] $path(echo) "first line" > $path(gorp.file) + list [exec [interpreter] $path(sh) -c "\"$path(echo)\" foo bar 1>&2" >>&$path(gorp.file)] \ + [exec [interpreter] $path(cat) $path(gorp.file)] +} "{} {first line\nfoo bar}" +test exec-4.4 {redirecting output and stderr to file} {exec} { + set f [open $path(gorp.file) w] + puts $f "Line 1" + flush $f + exec [interpreter] $path(echo) "More text" >&@ $f + exec [interpreter] $path(echo) >&@$f "Even more" + puts $f "Line 3" + close $f + exec [interpreter] $path(cat) $path(gorp.file) +} "Line 1\nMore text\nEven more\nLine 3" +test exec-4.5 {redirecting output and stderr to file} {exec} { + set f [open $path(gorp.file) w] + puts $f "Line 1" + flush $f + exec >&@ $f [interpreter] $path(sh) -c "\"$path(echo)\" foo bar 1>&2" + exec >&@$f [interpreter] $path(sh) -c "\"$path(echo)\" xyzzy 1>&2" + puts $f "Line 3" + close $f + exec [interpreter] $path(cat) $path(gorp.file) +} "Line 1\nfoo bar\nxyzzy\nLine 3" + +# I/O redirection: input from file. + +if {[testConstraint exec]} { + exec [interpreter] $path(echo) "Just a few thoughts" > $path(gorp.file) +} +test exec-5.1 {redirecting input from file} {exec} { + exec [interpreter] $path(cat) < $path(gorp.file) +} {Just a few thoughts} +test exec-5.2 {redirecting input from file} {exec stdio} { + exec [interpreter] $path(cat) | [interpreter] $path(cat) < $path(gorp.file) +} {Just a few thoughts} +test exec-5.3 {redirecting input from file} {exec stdio} { + exec [interpreter] $path(cat) < $path(gorp.file) | [interpreter] $path(cat) +} {Just a few thoughts} +test exec-5.4 {redirecting input from file} {exec stdio} { + exec < $path(gorp.file) [interpreter] $path(cat) | [interpreter] $path(cat) +} {Just a few thoughts} +test exec-5.5 {redirecting input from file} {exec} { + exec [interpreter] $path(cat) <$path(gorp.file) +} {Just a few thoughts} +test exec-5.6 {redirecting input from file} -constraints {exec} -body { + set f [open $path(gorp.file) r] + exec [interpreter] $path(cat) <@ $f +} -cleanup { + close $f +} -result {Just a few thoughts} +test exec-5.7 {redirecting input from file} -constraints {exec} -body { + set f [open $path(gorp.file) r] + exec <@$f [interpreter] $path(cat) +} -cleanup { + close $f +} -result {Just a few thoughts} + +# I/O redirection: standard error through a pipeline. + +test exec-6.1 {redirecting stderr through a pipeline} {exec stdio} { + exec [interpreter] $path(sh) -c "\"$path(echo)\" foo bar" |& [interpreter] $path(cat) +} "foo bar" +test exec-6.2 {redirecting stderr through a pipeline} {exec stdio} { + exec [interpreter] $path(sh) -c "\"$path(echo)\" foo bar 1>&2" |& [interpreter] $path(cat) +} "foo bar" +test exec-6.3 {redirecting stderr through a pipeline} {exec stdio} { + exec [interpreter] $path(sh) -c "\"$path(echo)\" foo bar 1>&2" \ + |& [interpreter] $path(sh) -c "\"$path(echo)\" second msg 1>&2 ; \"$path(cat)\"" |& [interpreter] $path(cat) +} "second msg\nfoo bar" + +# I/O redirection: combinations. + +set path(gorp.file2) [makeFile {} gorp.file2] + +test exec-7.1 {multiple I/O redirections} {exec} { + exec << "command input" > $path(gorp.file2) [interpreter] $path(cat) < $path(gorp.file) + exec [interpreter] $path(cat) $path(gorp.file2) +} {Just a few thoughts} +test exec-7.2 {multiple I/O redirections} {exec} { + exec < $path(gorp.file) << "command input" [interpreter] $path(cat) +} {command input} + +# Long input to command and output from command. +set a "0123456789 xxxxxxxxx abcdefghi ABCDEFGHIJK\n" +set a [concat $a $a $a $a] +set a [concat $a $a $a $a] +set a [concat $a $a $a $a] +set a [concat $a $a $a $a] +test exec-8.1 {long input and output} {exec} { + exec [interpreter] $path(cat) << $a +} $a +# More than 20 arguments to exec. +test exec-8.2 {long input and output} {exec} { + exec [interpreter] $path(echo) 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 +} {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23} + +# Commands that return errors. + +test exec-9.1 {commands returning errors} {exec notValgrind} { + set x [catch {exec gorp456} msg] + list $x [string tolower $msg] [string tolower $errorCode] +} {1 {couldn't execute "gorp456": no such file or directory} {posix enoent {no such file or directory}}} +test exec-9.2 {commands returning errors} {exec notValgrind} { + string tolower [list [catch {exec [interpreter] echo foo | foo123} msg] $msg $errorCode] +} {1 {couldn't execute "foo123": no such file or directory} {posix enoent {no such file or directory}}} +test exec-9.3 {commands returning errors} -constraints {exec stdio} -body { + exec [interpreter] $path(sleep) 1 | [interpreter] $path(exit) 43 | [interpreter] $path(sleep) 1 +} -returnCodes error -result {child process exited abnormally} +test exec-9.4 {commands returning errors} -constraints {exec stdio} -body { + exec [interpreter] $path(exit) 43 | [interpreter] $path(echo) "foo bar" +} -returnCodes error -result {foo bar +child process exited abnormally} +test exec-9.5 {commands returning errors} -constraints {exec stdio notValgrind} -body { + exec gorp456 | [interpreter] echo a b c +} -returnCodes error -result {couldn't execute "gorp456": no such file or directory} +test exec-9.6 {commands returning errors} -constraints {exec} -body { + exec [interpreter] $path(sh) -c "\"$path(echo)\" error msg 1>&2" +} -returnCodes error -result {error msg} +test exec-9.7 {commands returning errors} -constraints {exec stdio nonPortable} -body { + # This test can fail easily on multiprocessor machines + exec [interpreter] $path(sh) -c "\"$path(echo)\" error msg 1>&2 ; \"$path(sleep)\" 1" \ + | [interpreter] $path(sh) -c "\"$path(echo)\" error msg 1>&2 ; \"$path(sleep)\" 1" +} -returnCodes error -result {error msg +error msg} +set path(err) [makeFile {} err] +test exec-9.8 {commands returning errors} -constraints {exec} -setup { + set f [open $path(err) w] + puts $f { + puts stdout out + puts stderr err + } + close $f +} -body { + exec [interpreter] $path(err) +} -returnCodes error -result {out +err} + +# Errors in executing the Tcl command, as opposed to errors in the processes +# that are invoked. + +test exec-10.1 {errors in exec invocation} -constraints {exec} -body { + exec +} -returnCodes error -result {wrong # args: should be "exec ?-option ...? arg ?arg ...?"} +test exec-10.2 {errors in exec invocation} -constraints {exec} -body { + exec | cat +} -returnCodes error -result {illegal use of | or |& in command} +test exec-10.3 {errors in exec invocation} -constraints {exec} -body { + exec cat | +} -returnCodes error -result {illegal use of | or |& in command} +test exec-10.4 {errors in exec invocation} -constraints {exec} -body { + exec cat | | cat +} -returnCodes error -result {illegal use of | or |& in command} +test exec-10.5 {errors in exec invocation} -constraints {exec} -body { + exec cat | |& cat +} -returnCodes error -result {illegal use of | or |& in command} +test exec-10.6 {errors in exec invocation} -constraints {exec} -body { + exec cat |& +} -returnCodes error -result {illegal use of | or |& in command} +test exec-10.7 {errors in exec invocation} -constraints {exec} -body { + exec cat < +} -returnCodes error -result {can't specify "<" as last word in command} +test exec-10.8 {errors in exec invocation} -constraints {exec} -body { + exec cat > +} -returnCodes error -result {can't specify ">" as last word in command} +test exec-10.9 {errors in exec invocation} -constraints {exec} -body { + exec cat << +} -returnCodes error -result {can't specify "<<" as last word in command} +test exec-10.10 {errors in exec invocation} -constraints {exec} -body { + exec cat >> +} -returnCodes error -result {can't specify ">>" as last word in command} +test exec-10.11 {errors in exec invocation} -constraints {exec} -body { + exec cat >& +} -returnCodes error -result {can't specify ">&" as last word in command} +test exec-10.12 {errors in exec invocation} -constraints {exec} -body { + exec cat >>& +} -returnCodes error -result {can't specify ">>&" as last word in command} +test exec-10.13 {errors in exec invocation} -constraints {exec} -body { + exec cat >@ +} -returnCodes error -result {can't specify ">@" as last word in command} +test exec-10.14 {errors in exec invocation} -constraints {exec} -body { + exec cat <@ +} -returnCodes error -result {can't specify "<@" as last word in command} +test exec-10.15 {errors in exec invocation} -constraints {exec} -body { + exec cat < a/b/c +} -returnCodes error -result {couldn't read file "a/b/c": no such file or directory} +test exec-10.16 {errors in exec invocation} -constraints {exec} -body { + exec cat << foo > a/b/c +} -returnCodes error -result {couldn't write file "a/b/c": no such file or directory} +test exec-10.17 {errors in exec invocation} -constraints {exec} -body { + exec cat << foo > a/b/c +} -returnCodes error -result {couldn't write file "a/b/c": no such file or directory} +set f [open $path(gorp.file) w] +test exec-10.18 {errors in exec invocation} -constraints {exec} -body { + exec cat <@ $f +} -returnCodes error -result "channel \"$f\" wasn't opened for reading" +close $f +set f [open $path(gorp.file) r] +test exec-10.19 {errors in exec invocation} -constraints {exec} -body { + exec cat >@ $f +} -returnCodes error -result "channel \"$f\" wasn't opened for writing" +close $f +test exec-10.20.1 {errors in exec invocation} -constraints {unix exec notValgrind} -body { + exec ~non_existent_user/foo/bar +} -returnCodes error -result {couldn't execute "~non_existent_user/foo/bar": no such file or directory} +test exec-10.20.2 {errors in exec invocation} -constraints {win exec notValgrind} -body { + exec ~non_existent_user/foo/bar +} -returnCodes error -result {couldn't execute "~non_existent_user\foo\bar": no such file or directory} +test exec-10.21.1 {errors in exec invocation} -constraints {unix exec notValgrind} -body { + exec [interpreter] true | ~xyzzy_bad_user/x | false +} -returnCodes error -result {couldn't execute "~xyzzy_bad_user/x": no such file or directory} +test exec-10.21.2 {errors in exec invocation} -constraints {win exec notValgrind} -body { + exec [interpreter] true | ~xyzzy_bad_user/x | false +} -returnCodes error -result {couldn't execute "~xyzzy_bad_user\x": no such file or directory} +test exec-10.22 {errors in exec invocation} -constraints {exec notValgrind} -body { + exec echo test > ~non_existent_user/foo/bar +} -returnCodes error -result {couldn't write file "~non_existent_user/foo/bar": no such file or directory} +# Commands in background. + +test exec-11.1 {commands in background} {exec} { + set time [time {exec [interpreter] $path(sleep) 2 &}] + expr {[lindex $time 0] < 1000000} +} 1 +test exec-11.2 {commands in background} -constraints {exec} -body { + exec [interpreter] $path(echo) a &b +} -result {a &b} +test exec-11.3 {commands in background} {exec} { + llength [exec [interpreter] $path(sleep) 1 &] +} 1 +test exec-11.4 {commands in background} {exec stdio} { + llength [exec [interpreter] $path(sleep) 1 | [interpreter] $path(sleep) 1 | [interpreter] $path(sleep) 1 &] +} 3 +test exec-11.5 {commands in background} {exec} { + set f [open $path(gorp.file) w] + puts $f [list catch [list exec [info nameofexecutable] $path(echo) foo &]] + close $f + exec [interpreter] $path(gorp.file) +} foo + +# Make sure that background commands are properly reaped when they +# eventually die. + +if {[testConstraint exec] && [testConstraint nonPortable]} { + after 1300 + exec [interpreter] $path(sleep) 1 +} +test exec-12.1 {reaping background processes} {exec unix nonPortable} { + for {set i 0} {$i < 20} {incr i} { + exec echo foo > /dev/null & + } + after 1000 + catch {exec ps | fgrep "echo foo" | fgrep -v fgrep | wc} msg + lindex $msg 0 +} 0 +test exec-12.2 {reaping background processes} {exec unix nonPortable} { + exec sleep 2 | sleep 2 | sleep 2 & + catch {exec ps | fgrep -i "sleep" | fgrep -i -v fgrep | wc} msg + set x [lindex $msg 0] + after 3000 + catch {exec ps | fgrep -i "sleep" | fgrep -i -v fgrep | wc} msg + list $x [lindex $msg 0] +} {3 0} +test exec-12.3 {reaping background processes} {exec unix nonPortable} { + exec sleep 1000 & + exec sleep 1000 & + set x [exec ps | fgrep "sleep" | fgrep -v fgrep] + set pids {} + foreach i [split $x \n] { + lappend pids [lindex $i 0] + } + foreach i $pids { + catch {exec kill -STOP $i} + } + catch {exec ps | fgrep "sleep" | fgrep -v fgrep | wc} msg + set x [lindex $msg 0] + foreach i $pids { + catch {exec kill -KILL $i} + } + catch {exec ps | fgrep "sleep" | fgrep -v fgrep | wc} msg + list $x [lindex $msg 0] +} {2 0} + +# Make sure "errorCode" is set correctly. + +test exec-13.1 {setting errorCode variable} {exec} { + list [catch {exec [interpreter] $path(cat) < a/b/c} msg] [string tolower $errorCode] +} {1 {posix enoent {no such file or directory}}} +test exec-13.2 {setting errorCode variable} {exec} { + list [catch {exec [interpreter] $path(cat) > a/b/c} msg] [string tolower $errorCode] +} {1 {posix enoent {no such file or directory}}} +test exec-13.3 {setting errorCode variable} {exec notValgrind} { + set x [catch {exec _weird_cmd_} msg] + list $x [string tolower $msg] [lindex $errorCode 0] \ + [string tolower [lrange $errorCode 2 end]] +} {1 {couldn't execute "_weird_cmd_": no such file or directory} POSIX {{no such file or directory}}} +test exec-13.4 {extended exit result codes} -setup { + set tmp [makeFile {exit 0x00000101} tmpfile.exec-13.4] +} -constraints {win} -body { + list [catch {exec [interpreter] $tmp} err] [lreplace $::errorCode 1 1 {}] +} -cleanup { + removeFile $tmp +} -result {1 {CHILDSTATUS {} 257}} +test exec-13.5 {extended exit result codes: max value} -setup { + set tmp [makeFile {exit 0x3fffffff} tmpfile.exec-13.5] +} -constraints {win} -body { + list [catch {exec [interpreter] $tmp} err] [lreplace $::errorCode 1 1 {}] +} -cleanup { + removeFile $tmp +} -result {1 {CHILDSTATUS {} 1073741823}} +test exec-13.6 {extended exit result codes: signalled} -setup { + set tmp [makeFile {exit 0xC0000016} tmpfile.exec-13.6] +} -constraints {win} -body { + list [catch {exec [interpreter] $tmp} err] [lreplace $::errorCode 1 1 {}] +} -cleanup { + removeFile $tmp +} -result {1 {CHILDKILLED {} SIGABRT SIGABRT}} + +# Switches before the first argument + +test exec-14.1 {-keepnewline switch} {exec} { + exec -keepnewline [interpreter] $path(echo) foo +} "foo\n" +test exec-14.2 {-keepnewline switch} -constraints {exec} -body { + exec -keepnewline +} -returnCodes error -result {wrong # args: should be "exec ?-option ...? arg ?arg ...?"} +test exec-14.3 {unknown switch} -constraints {exec} -body { + exec -gorp +} -returnCodes error -result {bad option "-gorp": must be -ignorestderr, -keepnewline, or --} +test exec-14.4 {-- switch} -constraints {exec notValgrind} -body { + exec -- -gorp +} -returnCodes error -result {couldn't execute "-gorp": no such file or directory} +test exec-14.5 {-ignorestderr switch} {exec} { + # Alas, the use of -ignorestderr is buried here :-( + exec [interpreter] $path(sh2) -c [list $path(echo2) foo bar] 2>@1 +} "foo bar\nbar" + +# Redirecting standard error separately from standard output + +test exec-15.1 {standard error redirection} {exec} { + exec [interpreter] $path(echo) "First line" > $path(gorp.file) + list [exec [interpreter] $path(sh) -c "\"$path(echo)\" foo bar 1>&2" 2> $path(gorp.file)] \ + [exec [interpreter] $path(cat) $path(gorp.file)] +} {{} {foo bar}} +test exec-15.2 {standard error redirection} {exec stdio} { + list [exec [interpreter] $path(sh) -c "\"$path(echo)\" foo bar 1>&2" \ + | [interpreter] $path(echo) biz baz >$path(gorp.file) 2> $path(gorp.file2)] \ + [exec [interpreter] $path(cat) $path(gorp.file)] \ + [exec [interpreter] $path(cat) $path(gorp.file2)] +} {{} {biz baz} {foo bar}} +test exec-15.3 {standard error redirection} {exec stdio} { + list [exec [interpreter] $path(sh) -c "\"$path(echo)\" foo bar 1>&2" \ + | [interpreter] $path(echo) biz baz 2>$path(gorp.file) > $path(gorp.file2)] \ + [exec [interpreter] $path(cat) $path(gorp.file)] \ + [exec [interpreter] $path(cat) $path(gorp.file2)] +} {{} {foo bar} {biz baz}} +test exec-15.4 {standard error redirection} {exec} { + set f [open $path(gorp.file) w] + puts $f "Line 1" + flush $f + exec [interpreter] $path(sh) -c "\"$path(echo)\" foo bar 1>&2" 2>@ $f + puts $f "Line 3" + close $f + readfile $path(gorp.file) +} {Line 1 +foo bar +Line 3} +test exec-15.5 {standard error redirection} {exec} { + exec [interpreter] $path(echo) "First line" > "$path(gorp.file)" + exec [interpreter] "$path(sh)" -c "\"$path(echo)\" foo bar 1>&2" 2>> "$path(gorp.file)" + readfile $path(gorp.file) +} {First line +foo bar} +test exec-15.6 {standard error redirection} {exec stdio} { + exec [interpreter] "$path(sh)" -c "\"$path(echo)\" foo bar 1>&2" > "$path(gorp.file2)" 2> "$path(gorp.file)" \ + >& "$path(gorp.file)" 2> "$path(gorp.file2)" | [interpreter] $path(echo) biz baz + list [readfile $path(gorp.file)] [readfile $path(gorp.file2)] +} {{biz baz} {foo bar}} +test exec-15.7 {standard error redirection 2>@1} {exec stdio} { + # This redirects stderr output into normal result output from exec + exec [interpreter] "$path(sh)" -c "\"$path(echo)\" foo bar 1>&2" 2>@1 +} {foo bar} + +test exec-16.1 {flush output before exec} {exec} { + set f [open $path(gorp.file) w] + puts $f "First line" + exec [interpreter] $path(echo) "Second line" >@ $f + puts $f "Third line" + close $f + readfile $path(gorp.file) +} {First line +Second line +Third line} +test exec-16.2 {flush output before exec} {exec} { + set f [open $path(gorp.file) w] + puts $f "First line" + exec [interpreter] << {puts stderr {Second line}} >&@ $f > $path(gorp.file2) + puts $f "Third line" + close $f + readfile $path(gorp.file) +} {First line +Second line +Third line} + +test exec-17.1 {inheriting standard I/O} -constraints {exec} -setup { + set path(script) [makeFile {} script] + set f [open $path(script) w] + puts $f [list lassign [list \ + [info nameofexecutable] $path(gorp.file) $path(echo) $path(sleep) \ + ] exe file echo sleep] + puts $f { + close stdout + set f [open $file w] + catch {exec $exe $echo foobar &} + exec $exe $sleep 2 + close $f + } + close $f +} -body { + catch {exec [interpreter] $path(script)} result + list $result [readfile $path(gorp.file)] +} -cleanup { + removeFile $path(script) +} -result {{} foobar} + +test exec-18.1 {exec deals with weird file names} -body { + set path(fooblah) [makeFile {contents} "foo\[\{blah"] + exec [interpreter] $path(cat) $path(fooblah) +} -constraints {exec} -cleanup { + removeFile $path(fooblah) +} -result contents +test exec-18.2 {exec cat deals with weird file names} -body { + # This is cross-platform, but the cat isn't predictably correct on + # Windows. + set path(fooblah) [makeFile {contents} "foo\[\{blah"] + exec cat $path(fooblah) +} -constraints {exec tempNotWin} -cleanup { + removeFile $path(fooblah) +} -result contents + +# Note that this test cannot be adapted to work on Windows; that platform has +# no kernel support for an analog of O_APPEND. OTOH, that means we can assume +# that there is a POSIX shell... +# +# This test also fails in some cases when building with macOS +test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix notValgrind noosxCI} -setup { + set tmpfile [makeFile {0} tmpfile.exec-19.1] +} -body { + # Note that we have to allow for the current contents of the temporary + # file, which is why the result is 14 and not 12 + exec /bin/sh -c \ + {for a in 1 2 3; do sleep 1; echo $a; done} >>$tmpfile & + exec /bin/sh -c \ + {for a in 4 5 6; do sleep 1; echo $a >&2; done} 2>>$tmpfile & + exec /bin/sh -c \ + {for a in a b c; do sleep 1; echo $a; done} >>$tmpfile & + exec /bin/sh -c \ + {for a in d e f; do sleep 1; echo $a >&2; done} 2>>$tmpfile & + # The above four shell invocations take about 3 seconds to finish, so allow + # 5s (in case the machine is busy) + after 5000 + # Check that no bytes have got lost through mixups with overlapping + # appends, which is only guaranteed to work when we set O_APPEND on the + # file descriptor in the [exec >>...] + file size $tmpfile +} -cleanup { + removeFile $tmpfile +} -result 26 + +# Tests to ensure batch files and .CMD (Bug 9ece99d58b) +# can be executed on Windows +test exec-20.0 {exec .bat file} -constraints {win} -body { + set log [makeFile {} exec20.log] + exec [makeFile "echo %1> $log" exec20.bat] "Testing exec-20.0" + viewFile $log +} -result "\"Testing exec-20.0\"" +test exec-20.1 {exec .CMD file} -constraints {win} -body { + set log [makeFile {} exec201.log] + exec [makeFile "echo %1> $log" exec201.CMD] "Testing exec-20.1" + viewFile $log +} -result "\"Testing exec-20.1\"" + +# Test with encoding mismatches (Bug 0f1ddc0df7fb7) +test exec-21.1 {exec encoding mismatch on stdout} -setup { + set path(script) [makeFile { + fconfigure stdout -translation binary + puts a\xe9b + } script] + set enc [encoding system] + encoding system utf-8 +} -cleanup { + removeFile $path(script) + encoding system $enc +} -body { + exec [info nameofexecutable] $path(script) +} -result a\uFFFDb +test exec-21.2 {exec encoding mismatch on stderr} -setup { + set path(script) [makeFile { + fconfigure stderr -translation binary + puts stderr a\xe9b + } script] + set enc [encoding system] + encoding system utf-8 +} -cleanup { + removeFile $path(script) + encoding system $enc +} -body { + list [catch {exec [info nameofexecutable] $path(script)} r] $r +} -result [list 1 a\uFFFDb] + + +# ---------------------------------------------------------------------- +# cleanup + +foreach file {gorp.file gorp.file2 echo echo2 cat wc sh sh2 sleep exit err} { + removeFile $file +} +unset -nocomplain path + +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# End: diff --git a/src/tests/core/tcl/testsuites/tests/tcltests.tcl b/src/tests/core/tcl/testsuites/tests/tcltests.tcl new file mode 100644 index 00000000..43f0f604 --- /dev/null +++ b/src/tests/core/tcl/testsuites/tests/tcltests.tcl @@ -0,0 +1,125 @@ +#! /usr/bin/env tclsh + +# Don't overwrite tcltests facilities already present +if {[package provide tcltests] ne {}} return + +package require tcltest 2.5 +namespace import ::tcltest::* +testConstraint exec [llength [info commands exec]] +testConstraint deprecated [expr {![tcl::build-info no-deprecate]}] +testConstraint debug [tcl::build-info debug] +testConstraint purify [tcl::build-info purify] +testConstraint debugpurify [ + expr { + ![tcl::build-info memdebug] + && [testConstraint debug] + && [testConstraint purify] + }] +testConstraint bigmem [expr {[ + info exists ::env(TCL_TESTCONSTRAINT_BIGMEM)] + ? !!$::env(TCL_TESTCONSTRAINT_BIGMEM) + : 1 +}] +testConstraint fcopy [llength [info commands fcopy]] +testConstraint fileevent [llength [info commands fileevent]] +testConstraint thread [expr {![catch {package require Thread 2.7-}]}] +testConstraint notValgrind [expr {![testConstraint valgrind]}] + + +namespace eval ::tcltests { + + + proc init {} { + if {[namespace which ::tcl::file::tempdir] eq {}} { + interp alias {} [namespace current]::tempdir {} [ + namespace current]::tempdir_alternate + } else { + interp alias {} [namespace current]::tempdir {} ::tcl::file::tempdir + } + } + + + # Stolen from dict.test + proc scriptmemcheck script { + set end [lindex [split [memory info] \n] 3 3] + for {set i 0} {$i < 5} {incr i} { + uplevel 1 $script + set tmp $end + set end [lindex [split [memory info] \n] 3 3] + } + expr {$end - $tmp} + } + + + proc tempdir_alternate {} { + close [file tempfile tempfile] + set tmpdir [file dirname $tempfile] + set execname [info nameofexecutable] + regsub -all {[^[:alpha:][:digit:]]} $execname _ execname + for {set i 0} {$i < 10000} {incr i} { + set time [clock milliseconds] + set name $tmpdir/${execname}_${time}_$i + if {![file exists $name]} { + file mkdir $name + return $name + } + } + error [list {could not create temporary directory}] + } + + # Generates test cases for 0, min and max number of arguments for a command. + # Expected result is as generated by Tcl_WrongNumArgs + # Only works if optional arguments come after fixed arguments + # E.g. + # testnumargs "zipfs mount" "" "?mountpoint? ?zipfile? ?password?" + # testnumargs "lappend" "varName" "?value ...?" + proc testnumargs {cmd {fixed {}} {optional {}} args} { + variable count + set minargs [llength $fixed] + set maxargs [expr {$minargs + [llength $optional]}] + if {[regexp {\.\.\.\??$} [lindex $optional end]]} { + unset maxargs; # No upper limit on num of args + } + set message "wrong # args: should be \"$cmd" + if {[llength $fixed]} { + append message " $fixed" + } + if {[llength $optional]} { + append message " $optional" + } + if {[llength $fixed] == 0 && [llength $optional] == 0} { + append message " \"" + } else { + append message "\"" + } + set label [join $cmd -] + if {$minargs > 0} { + set arguments [lrepeat [expr {$minargs-1}] x] + test $label-minargs-[incr count($label-minargs)] \ + "$label no arguments" \ + -body "$cmd" \ + -result $message -returnCodes error \ + {*}$args + if {$minargs > 1} { + test $label-minargs-[incr count($label-minargs)] \ + "$label missing arguments" \ + -body "$cmd $arguments" \ + -result $message -returnCodes error \ + {*}$args + } + } + if {[info exists maxargs]} { + set arguments [lrepeat [expr {$maxargs+1}] x] + test $label-maxargs-[incr count($label-maxargs)] \ + "$label extra arguments" \ + -body "$cmd $arguments" \ + -result $message -returnCodes error \ + {*}$args + } + } + + init + + package provide tcltests 0.1 +} + diff --git a/src/tests/modules/AGENTS.md b/src/tests/modules/AGENTS.md new file mode 100644 index 00000000..6bb01682 --- /dev/null +++ b/src/tests/modules/AGENTS.md @@ -0,0 +1,34 @@ +# src/tests/modules — Source Module Test Suites + +## Purpose + +Unit tests for editable source modules under `src/modules/`, `src/modules_tcl8/`, and `src/modules_tcl9/`. These tests use `tcltest` and run against the uninstalled source tree through `src/tests/runtests.tcl`. + +## Ownership + +- Agents should add or update tests here when changing module behavior in `src/modules/` or Tcl-version-specific module trees. +- Installed-module test packages under `src/modules/test/` are packaging artifacts and are not the default place for source-tree behavior tests. +- Do not delete, skip, or weaken existing tests without explicit user direction. + +## Local Contracts + +- The directory hierarchy mirrors module namespace paths, such as `src/tests/modules/punk/args/` for `punk::args`. +- Test files use `.test` extension and must `package require` any extra packages explicitly. +- Test files may commonly use line-continuation backslashes, and existing Tcl expand-syntax structures in tests should not be refactored into line continuations. +- Tests must exercise source modules as loaded by `src/tests/runtests.tcl`, not installed or built output modules. + +## Work Guidance + +- Put new module tests under `src/tests/modules//testsuites//` following nearby layout. +- Prefer `try { ... } on error {result options} { ... }` for structured error capture in test bodies. +- Focused verification should mirror production pipelines inside tests using Punk pipeline syntax when that parity matters. +- Capture enough stderr or failure context to identify the failing command or assertion. + +## Verification + +- Run targeted module tests with ` src/tests/runtests.tcl -include-paths modules//**`. +- Run a single test by name with ` src/tests/runtests.tcl -tcltestoptions {-match } -include-paths modules//**`. +- Run a specific test file by adding its file tail, such as ` src/tests/runtests.tcl -include-paths modules/punk/args/** parsekey.test`. + +## Child DOX Index + diff --git a/src/tests/modules/opunk/str/testsuites/tests/str.test b/src/tests/modules/opunk/str/testsuites/tests/str.test index 25d3ceed..e6a8bb80 100644 --- a/src/tests/modules/opunk/str/testsuites/tests/str.test +++ b/src/tests/modules/opunk/str/testsuites/tests/str.test @@ -66,6 +66,7 @@ namespace eval ::testspace { -setup $common -body { set text "abcde" set o [opunk::Str new $text] + #error testerr set result [list \ [string equal $text [opunk::Str::get $o]] \ [opunk::Str::count $o] \ @@ -76,7 +77,7 @@ namespace eval ::testspace { -cleanup { }\ -result [list {*}{ - 1 5 0 + 1 5 0 }] } diff --git a/src/tests/modules/punk/args/testsuites/args/alias.test b/src/tests/modules/punk/args/testsuites/args/alias.test new file mode 100644 index 00000000..8d4edad3 --- /dev/null +++ b/src/tests/modules/punk/args/testsuites/args/alias.test @@ -0,0 +1,43 @@ +package require tcltest + +package require punk::ns + +namespace eval ::testspace { + namespace import ::tcltest::* + variable common { + set result "" + } + + + test documented_alias {Test docs from documented alias take preference}\ + -setup $common -body { + proc underlying {args} {return underlying-$args} + interp alias "" ::testspace::doit "" ::testspace::underlying curriedarg1 + #punk::ns::cmdhelp = 'i doit' + set helpoutput [punk::ns::cmdhelp -return string doit] + lappend result [string match "*::testspace::underlying*" $helpoutput] + set synoutput [punk::ns::synopsis doit] + #check we see the curried argument in the synopsis + lappend result [string match "*curriedarg1*" $synoutput] + + #define an overiding doc on the alias + punk::args::define {@id -id ::testspace::doit} {@cmd -help "doit help"} @values {extra -multiple 1 -type any} + set helpoutput [punk::ns::cmdhelp -return string doit] + lappend result [string match "*doit help*" $helpoutput] + set synoutput [punk::ns::synopsis doit] + puts stderr ------------------- + puts stderr $synoutput + puts stderr ------------------- + lappend result [string match "*extra*" $synoutput] + + }\ + -cleanup { + interp alias "" ::testspace::doit "" + punk::args::undefine ::testspace::doit + }\ + -result [list\ + 1 1 1 1\ + ] + +} +tcltest::cleanupTests ;#needed to produce test summary. \ No newline at end of file diff --git a/src/tests/modules/punk/args/testsuites/args/args.test b/src/tests/modules/punk/args/testsuites/args/args.test new file mode 100644 index 00000000..0015cfb4 --- /dev/null +++ b/src/tests/modules/punk/args/testsuites/args/args.test @@ -0,0 +1,631 @@ + +package require tcltest + +package require punk::args + +namespace eval ::testspace { + namespace import ::tcltest::* + variable common { + set result "" + } + + + test parse_withdef_leaders_ordering_defaults {Test ordering of leaders when some have defaults}\ + -setup $common -body { + set argd [punk::args::parse {a b} withdef @leaders x {y -default 1}] + set docid [dict get $argd id] + set vals [dict get $argd leaders] + set result $vals + }\ + -cleanup { + punk::args::undefine $docid 1 + }\ + -result [list\ + x a y b + ] + + + test parse_withdef_auto_change_argspace_from_options_to_values {test first non dashed argdef after option is treated as a value when @values not explicit}\ + -setup $common -body { + #test val1 following -opt is automatically placed in 'values' when @values directive is missing + set argd [punk::args::parse {-opt 1 b} withdef -opt val1] + set docid [dict get $argd id] + set vals [dict get $argd values] + set result $vals + }\ + -cleanup { + punk::args::undefine $docid 1 + }\ + -result [list\ + val1 b + ] + + + test parse_withdef_option_ordering_defaults {Test ordering of options when some have defaults}\ + -setup $common -body { + #for consistency with leaders and values dicts - try to maintain definition order for options too + set argd [punk::args::parse {-x a -y b} withdef @opts -x {-y -default 1}] + set docid [dict get $argd id] + set vals [dict get $argd opts] + set result $vals + }\ + -cleanup { + punk::args::undefine $docid 1 + }\ + -result [list\ + -x a -y b + ] + + test parse_withdef_option_ordering_defaults2 {Test ordering of options when some have defaults and -any is true}\ + -setup $common -body { + #for consistency with leaders and values dicts - try to maintain definition order for options too + set argd [punk::args::parse {-blah etc -x a -y b -solo -z c} withdef {@opts -any 1} -x {-y -default 1} {-solo -type none} -z] + set docid [dict get $argd id] + set vals [dict get $argd opts] + set result $vals + }\ + -cleanup { + punk::args::undefine $docid 1 + }\ + -result [list\ + -x a -y b -solo 1 -z c -blah etc + ] + + test parse_withdef_values_ordering_defaults {Test ordering of values when some have defaults}\ + -setup $common -body { + set argd [punk::args::parse {a b} withdef @values x {y -default 1}] + set docid [dict get $argd id] + set vals [dict get $argd values] + set result $vals + }\ + -cleanup { + punk::args::undefine $docid 1 + }\ + -result [list\ + x a y b + ] + + test parse_withdef_values_no_phantom_default {Test no phantom default with intermediate optional argument}\ + -setup $common -body { + #y was not received, and has no default, so should not appear in 'values' element + #we don't want to see {x a y {} z b} + set argd [punk::args::parse {a b} withdef @values x {y -optional 1} z] + set docid [dict get $argd id] + set vals [dict get $argd values] + set result $vals + }\ + -cleanup { + punk::args::undefine $docid 1 + }\ + -result [list\ + x a z b + ] + test parse_withdef_value_multiple1 {Test named value with -multiple true and required trailing value}\ + -setup $common -body { + set argd [punk::args::parse {a b c} withdef @values {arg -type string -multiple 1} endval] + set docid [dict get $argd id] + lappend result [dict get $argd leaders] + lappend result [dict get $argd values] + }\ + -cleanup { + punk::args::undefine $docid 1 + }\ + -result [list\ + {} {arg {a b} endval c} + ] + + test parse_withdef_value_multiple2 {Test named value followed by named value with -multiple true and a default}\ + -setup $common -body { + set argd [punk::args::parse {a b c} withdef @values A {arg -type string -multiple 1 -default X}] + set docid [dict get $argd id] + lappend result [dict get $argd leaders] + lappend result [dict get $argd values] + }\ + -cleanup { + punk::args::undefine $docid 1 + }\ + -result [list\ + {} {A a arg {b c}} + ] + + test parse_withdef_leader_multiple1 {Test named leader with -multiple true and 1 value required}\ + -setup $common -body { + set argd [punk::args::parse {a b c} withdef {@leaders -min 0} {L -multiple 1} {@values -min 1 -max 1} V] + set docid [dict get $argd id] + lappend result [dict get $argd leaders] + lappend result [dict get $argd values] + }\ + -cleanup { + punk::args::undefine $docid 1 + }\ + -result [list\ + {L {a b}} {V c} + ] + + test parse_withdef_leader_min_max1 {Test unnamed leaders with @leaders -min and -max}\ + -setup $common -body { + set argd [punk::args::parse {a b c d} withdef {@leaders -min 1 -max 3 -unnamed true} {@values -unnamed true} ] + set docid [dict get $argd id] + lappend result [dict get $argd leaders] + lappend result [dict get $argd values] + }\ + -cleanup { + punk::args::undefine $docid 1 + }\ + -result [list\ + {0 a 1 b 2 c} {3 d} + ] + test parse_withdef_leader_min_max_with_required_value {Test unnamed leaders with -min and -max followed by required unnamed value}\ + -setup $common -body { + #should not error - should allocate d to values + set argd [punk::args::parse {a b c d} withdef {@leaders -min 1 -max 4 -unnamed true} {@values -min 1 -max 1 -unnamed true}] + set docid [dict get $argd id] + lappend result [dict get $argd leaders] + lappend result [dict get $argd values] + }\ + -cleanup { + punk::args::undefine $docid 1 + }\ + -result [list\ + {0 a 1 b 2 c} {3 d} + ] + + test parse_withdef_leaderclause_trailing_optional_members_followed_by_value {Test that last leader clause with optional members works with following required value}\ + -setup $common -body { + set docids [list] + set argd [punk::args::parse {a z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {@values} val] + lappend docids [dict get $argd id] + lappend result [dict get $argd leaders] + set argd [punk::args::parse {a 1 z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {@values} val] + lappend docids [dict get $argd id] + lappend result [dict get $argd leaders] + set argd [punk::args::parse {a 1 2 z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {@values} val] + lappend docids [dict get $argd id] + lappend result [dict get $argd leaders] + }\ + -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } + }\ + -result [list\ + {ldr {a {} {}}}\ + {ldr {a 1 {}}}\ + {ldr {a 1 2}}\ + ] + test parse_withdef_leaderclause_trailing_optional_members_followed_by_optional_leader_and_value {Test that last leader clause with optional members works with following required value}\ + -setup $common -body { + set docids [list] + set argd [punk::args::parse {x y z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {ldr2 -type string -optional 1} {@values} val] + lappend docids [dict get $argd id] + lappend result [dict get $argd leaders] + + set argd [punk::args::parse {x 1 z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {ldr2 -type string -optional 1} {@values} val] + lappend docids [dict get $argd id] + lappend result [dict get $argd leaders] + + set argd [punk::args::parse {x 1 y z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {ldr2 -type string -optional 1} {@values} val] + lappend docids [dict get $argd id] + lappend result [dict get $argd leaders] + + set argd [punk::args::parse {x 1 2 y z} withdef {@leaders} {ldr -type {char ?int? ?int?}} {ldr2 -type string -optional 1} {@values} val] + lappend docids [dict get $argd id] + lappend result [dict get $argd leaders] + }\ + -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } + }\ + -result [list\ + {ldr {x {} {}} ldr2 y}\ + {ldr {x 1 {}}}\ + {ldr {x 1 {}} ldr2 y}\ + {ldr {x 1 2} ldr2 y}\ + ] + + test parse_withdef_value_clause_typedefaults {test clause with optional element and -typedefaults specified}\ + -setup $common -body { + set argd [punk::args::parse {1} withdef @values {v -type {int ?int?} -typedefaults {"" 12}}] + set docid [dict get $argd id] + lappend result [dict get $argd values] + }\ + -cleanup { + punk::args::undefine $docid 1 + }\ + -result [list\ + {v {1 12}} + ] + test parse_withdef_value_clause_typedefaults2 {test clause with optional element and -typedefaults specified - entire arg optional -default}\ + -setup $common -body { + #-default has deliberate type violations - should still produce result as default is not meant to be subject to validation. + set argd [punk::args::parse {} withdef @values {v -type {int ?int?} -typedefaults {"" 12} -default {x y} -optional 1}] + set docid [dict get $argd id] + lappend result [dict get $argd values] + }\ + -cleanup { + punk::args::undefine $docid 1 + }\ + -result [list\ + {v {x y}} + ] + + test parse_withdef_value_clause_defaulted_optional {test clause with optional element and -typedefaults not matching all types}\ + -setup $common -body { + #-typedefaults has deliberate type violations - should still produce result as defaulted value is not meant to be subject to validation. + #(uses the ?defaulted-? typelist mechanism) + set argd [punk::args::parse {1} withdef @values {v -type {int ?int?} -typedefaults {"" xxx}}] + set docid [dict get $argd id] + lappend result [dict get $argd values] + }\ + -cleanup { + punk::args::undefine $docid 1 + }\ + -result [list\ + {v {1 xxx}} + ] + test parse_withdef_value_clause_missing_optional {test clause with optional element and no -typedefaults}\ + -setup $common -body { + #an optional clause member will be replaced with empty string when missing if there is no -typedefaults + #This empty string needs to be in the result, but not be subject to validation + #(uses the ?ommitted-? typelist mechanism) + set argd [punk::args::parse {1} withdef @values {v -type {int ?int?}}] + set docid [dict get $argd id] + lappend result [dict get $argd values] + }\ + -cleanup { + punk::args::undefine $docid 1 + }\ + -result [list\ + {v {1 {}}} + ] + + test parse_withdef_value_clause_arity1 {Test value clause result with optional member}\ + -setup $common -body { + #default for missing optional member ?literal(then)? should be empty string + set argd [punk::args::parse {elseif 1 x} withdef {@values} {"elseifclause" -type {literal(elseif) expr ?literal(then)? any}}] + set docid [dict get $argd id] + lappend result [dict get $argd values] + }\ + -cleanup { + punk::args::undefine $docid 1 + }\ + -result [list\ + {elseifclause {elseif 1 {} x}} + ] + + test parse_withdef_value_clause_missing_optional_multiple {test -multiple true clauses with optional members}\ + -setup $common -body { + #this test is applicable to situations such as the elseif clause in the ::if definition: + #e.g literal(elseif) expr ?literal(then)? script + #the 'then' needs to be omitable arbitrarily in a list of elseif clauses + + set docids [list] + + #first test with all values supplied + set argd [punk::args::parse {x 1 y x 2 y} withdef @values {triple -type {literal(x) ?int? literal(y)} -multiple 1}] + lappend docids [dict get $argd id] + lappend result [dict get $argd values] + + #missing value in second instance only + set argd [punk::args::parse {x 1 y x y} withdef @values {triple -type {literal(x) ?int? literal(y)} -multiple 1}] + lappend docids [dict get $argd id] + lappend result [dict get $argd values] + + #missing value in first instance only + #this can trigger a problem whereby the missing value in the first instance (which is empty string) gets processed in validation against 'int' and fails. + #(updating of required type to a validationless value such as ... ?omitted-int? ... needs to be tied to specific clause instances) + set argd [punk::args::parse {x y x 2 y} withdef @values {triple -type {literal(x) ?int? literal(y)} -multiple 1}] + lappend docids [dict get $argd id] + lappend result [dict get $argd values] + + #for completeness - no optional values supplid + set argd [punk::args::parse {x y x y} withdef @values {triple -type {literal(x) ?int? literal(y)} -multiple 1}] + lappend docids [dict get $argd id] + lappend result [dict get $argd values] + + }\ + -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } + }\ + -result [list\ + {triple {{x 1 y} {x 2 y}}}\ + {triple {{x 1 y} {x {} y}}}\ + {triple {{x {} y} {x 2 y}}}\ + {triple {{x {} y} {x {} y}}}\ + ] + + + + + test parse_withdef_value_clause_arity2 {Test value clause result with missing optional member in optional clauses at tail}\ + -setup $common -body { + set docids [list] + set argd [punk::args::parse {1 2 x 1 y} withdef {@values -unnamed true} {arg -multiple 1} {X -type {literal(x) any} -optional 1} {Y -type {literal(y) ?int?} -optional 1}] + lappend docids [dict get $argd id] + lappend result [dict get $argd values] + }\ + -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } + }\ + -result [list\ + {arg {1 2} X {x 1} Y {y {}}} + ] + + + test parse_withdef_value_clause_arity3 {Test value clause result with filled optional member in optional clauses at tail}\ + -setup $common -body { + set docids [list] + set argd [punk::args::parse {1 2 x 1 y 2} withdef {@values -unnamed true} {arg -multiple 1} {X -type {literal(x) any} -optional 1} {Y -type {literal(y) ?int?} -optional 1}] + lappend docids [dict get $argd id] + lappend result [dict get $argd values] + }\ + -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } + }\ + -result [list\ + {arg {1 2} X {x 1} Y {y 2}} + ] + + test parse_withdef_value_optionality_type_detection {Test optional values assigned based on type}\ + -setup $common -body { + set docids [list] + + set def [list @values {i -type int -optional 1} {d -type dict -optional 1}] + + set argd [punk::args::parse {3} withdef {*}$def] + lappend docids [dict get $argd id] + lappend result [dict get $argd values] + + set argd [punk::args::parse {{k v}} withdef {*}$def] + lappend docids [dict get $argd id] + lappend result [dict get $argd values] + + set argd [punk::args::parse {3 {k v}} withdef {*}$def] + lappend docids [dict get $argd id] + lappend result [dict get $argd values] + + set argd [punk::args::parse {} withdef {*}$def] + lappend docids [dict get $argd id] + lappend result [dict get $argd values] + } {*}{ + -cleanup } { + foreach id $docids { + punk::args::undefine $id 1 + } + } {*}{ + -result } [list {*}{ + {i 3} + {d {k v}} + {i 3 d {k v}} + {} + }] + + # test L1 parsed to Lit1 not arg + #punk::args::parse {x y L1} withdef @values (arg -multiple 1) {lit1 -type literal(L1) -optional 1} {lit2 -type literal(L2) -optional 1} + test parse_withdef_value_leading_multiple_not_greedy_with_trailing_literal {Test value clause with leading -multiple true clause is not greedy when trailing literal can be matched}\ + -setup $common -body { + set docids [list] + set argd [punk::args::parse {x y L1} withdef @values {arg -multiple 1} {lit1 -type literal(L1) -optional 1} {lit2 -type literal(L2) -optional 1}] + lappend docids [dict get $argd id] + lappend result [dict get $argd values] + }\ + -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } + }\ + -result [list\ + {arg {x y} lit1 L1} + ] + + #test the same with literalprefix type + test parse_withdef_value_leading_multiple_not_greedy_with_trailing_literalprefix { + -setup $common -body { + set docids [list] + set argd [punk::args::parse {x y te} withdef @values {arg -multiple 1} {lit1 -type literalprefix(test) -optional 1} {lit2 -type literalprefix(other) -optional 1}] + lappend docids [dict get $argd id] + lappend result [dict get $argd values] + }\ + -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } + }\ + -result [list\ + {arg {x y} lit1 test}\ + ] + } + + #todo + #see i -form 1 file copy -- x + #fix end-of-opts handling + #see also file copy -force x + #(not handled by punk::args as the command does..) + + test parse_withdef_leader_clause {Test leader clause with multiple}\ + -setup $common -body { + set docids [list] + #see for example ::tcl::dict::create which has a clause length of 2 + set argd [punk::args::parse {k v e k1 v1 k2 v2} withdef {@leaders} {"key val etc" -type {any any any} -multiple 0} {"key val" -type {any any} -multiple 1} {@values -min 0 -max 0}] + lappend docids [dict get $argd id] + lappend result [dict get $argd leaders] + }\ + -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } + }\ + -result [list\ + {{key val etc} {k v e} {key val} {{k1 v1} {k2 v2}}} + ] + + test parse_withdef_value_clause_multiple {Test value clause with multiple}\ + -setup $common -body { + set docids [list] + #see for example ::tcl::dict::create which has a clause length of 2 + set argd [punk::args::parse {k v e k1 v1 k2 v2} withdef {@values} {"key val etc" -type {any any any} -multiple 0} {"key val" -type {any any} -multiple 1}] + lappend docids [dict get $argd id] + lappend result [dict get $argd values] + }\ + -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } + }\ + -result [list\ + {{key val etc} {k v e} {key val} {{k1 v1} {k2 v2}}} + ] + + test parse_withdef_value_clause_error {Test value clause with error due to not enough args for clause}\ + -setup $common -body { + set docids [list] + #see for example ::tcl::dict::create which has a clause length of 2 + if {[catch {punk::args::parse {k v} withdef {@values} {"key val etc" -type {any any any} -multiple 0}} emsg eopts]} { + set expected [dict get $eopts -errorcode] + if {[lindex $expected 0] eq "PUNKARGS" && [lindex $expected 1] eq "VALIDATION" && [lindex $expected 2 0] eq "missingrequiredvalue"} { + lappend result "RECEIVED_EXPECTED_ERROR" + } else { + lappend result "WRONG_ERROR_RECEIVED - $expected (expected PUNKARGS VALIDATION {missingrequiredvalue ...} ..." + } + #REVIEW - when an error is raised in parsing the arguments, but this is the 1st time we used this def, an autoid is still generated - but + #we don't have the id available (unless we scraped the error msg) in order to delete it. + #perhaps no big deal ? + #we could provide facility in punk::args to undefine via the deflist. + } else { + lappend docids [dict get $emsg id] + lappend result "MISSING_REQUIRED_ERROR" + } + }\ + -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } + }\ + -result [list\ + "RECEIVED_EXPECTED_ERROR" + ] + + + + test parse_withdef_leader_literalprefix_fullvalue {leaders - ensure supplying a prefix of literalprefix(test) returns full value 'test'}\ + -setup $common -body { + set docids [list] + set argd [punk::args::parse {t} withdef @leaders {A -type literalprefix(test)}] + lappend docids [dict get $argd id] + lappend result [dict get $argd leaders] + }\ + -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } + }\ + -result [list\ + {A test} + ] + + test parse_withdef_value_literalprefix_fullvalue {values - ensure supplying a prefix of literalprefix(test) returns full value 'test'}\ + -setup $common -body { + set docids [list] + set argd [punk::args::parse {t} withdef @values {A -type literalprefix(test)}] + lappend docids [dict get $argd id] + lappend result [dict get $argd values] + }\ + -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } + }\ + -result [list\ + {A test} + ] + + test parse_withdef_value_literal_alternates_case {values - ensure literal alternates work and preserve case}\ + -setup $common -body { + set docids [list] + set argd [punk::args::parse {abc} withdef @values {A -type literal(abc)|literal(DeF)}] + lappend docids [dict get $argd id] + lappend result [dict get $argd values] + set argd [punk::args::parse {DeF} withdef @values {A -type literal(abc)|literal(DeF)}] + lappend docids [dict get $argd id] + lappend result [dict get $argd values] + }\ + -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } + }\ + -result [list\ + {A abc} {A DeF} + ] + + test parse_withdef_value_literalprefix_literal_combo {values - ensure literal/literalprefix prefix calculation works}\ + -setup $common -body { + set docids [list] + set argd [punk::args::parse {test} withdef @values {A -type literalprefix(testinfo)|literal(test)}] + lappend docids [dict get $argd id] + lappend result [dict get $argd values] + set argd [punk::args::parse {testin} withdef @values {A -type literalprefix(testinfo)|literal(test)}] + lappend docids [dict get $argd id] + lappend result [dict get $argd values] + }\ + -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } + }\ + -result [list\ + {A test} {A testinfo} + ] + + test parse_withdef_value_alternatetypes {values - ensure alternate types (in simple-syntax) pass validation}\ + -setup $common -body { + set docids [list] + #both should pass validation + set argd [punk::args::parse {a} withdef @values {A -type int|char}] + lappend docids [dict get $argd id] + lappend result [dict get $argd values] + set argd [punk::args::parse {11} withdef @values {A -type char|int}] + lappend docids [dict get $argd id] + lappend result [dict get $argd values] + + #todo RPN? + #set argd [punk::args::parse {11} withdef @values {A -type {char int OR}}] + #set argd [punk::args::parse {11} withdef @values {A -type {char int stringstartswith | OR}}] + }\ + -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } + }\ + -result [list\ + {A a} {A 11} + ] + + test parse_same_autoid {Test that repeat use of same def uses same autoid}\ + -setup $common -body { + set docids [list] + set argd [punk::args::parse {a b c} withdef @values {arg -type string -multiple 1} endval] + lappend docids [dict get $argd id] + set argd [punk::args::parse {x y z} withdef @values {arg -type string -multiple 1} endval] + lappend docids [dict get $argd id] + lappend result [string equal [lindex $docids 0] [lindex $docids 1]] + }\ + -cleanup { + puts stderr "Expect output on stderr about punk::args::undefine unable to find id" + #second undefine warning is expected + foreach id $docids { + punk::args::undefine $id 0 ;#0 to ensure non-quiet -(msg on stderr) + } + }\ + -result [list\ + 1 + ] +} +tcltest::cleanupTests ;#needed to produce test summary line. diff --git a/src/tests/modules/punk/args/testsuites/args/choices.test b/src/tests/modules/punk/args/testsuites/args/choices.test new file mode 100644 index 00000000..1fa19622 --- /dev/null +++ b/src/tests/modules/punk/args/testsuites/args/choices.test @@ -0,0 +1,197 @@ +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}}\ + ] +} +tcltest::cleanupTests ;#needed to produce test summary line. + diff --git a/src/tests/modules/punk/args/testsuites/args/define.test b/src/tests/modules/punk/args/testsuites/args/define.test new file mode 100644 index 00000000..27c74481 --- /dev/null +++ b/src/tests/modules/punk/args/testsuites/args/define.test @@ -0,0 +1,129 @@ +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 + ] +} +tcltest::cleanupTests ;#needed to produce test summary line. diff --git a/src/tests/modules/punk/args/testsuites/args/mashopts.test b/src/tests/modules/punk/args/testsuites/args/mashopts.test new file mode 100644 index 00000000..0482ad99 --- /dev/null +++ b/src/tests/modules/punk/args/testsuites/args/mashopts.test @@ -0,0 +1,226 @@ + +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\ + ] + +} +tcltest::cleanupTests ;#needed to produce test summary line. diff --git a/src/tests/modules/punk/args/testsuites/args/opts.test b/src/tests/modules/punk/args/testsuites/args/opts.test new file mode 100644 index 00000000..08e9f9ac --- /dev/null +++ b/src/tests/modules/punk/args/testsuites/args/opts.test @@ -0,0 +1,77 @@ + +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}\ + ] +} +tcltest::cleanupTests ;#needed to produce test summary line. diff --git a/src/tests/modules/punk/args/testsuites/args/parsekey.test b/src/tests/modules/punk/args/testsuites/args/parsekey.test new file mode 100644 index 00000000..43c9c83c --- /dev/null +++ b/src/tests/modules/punk/args/testsuites/args/parsekey.test @@ -0,0 +1,180 @@ + +package require tcltest + +namespace eval ::testspace { + namespace import ::tcltest::* + variable common { + set result "" + } + + + test parsekey_repeat_ordering {Ensure last flag has precedence}\ + -setup $common -body { + set docids [list] + #It must always be possible to override earlier (non -multiple) options + set argd [punk::args::parse {-incr -decr -incr} withdef {@opts -type none -parsekey -direction} {-incr -typedefaults u} {-decr -typedefaults u}] + lappend docids [dict get $argd id] + lappend result [dict get $argd opts] + }\ + -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } + }\ + -result [list\ + {-direction u} + ] + + + test parsekey_opt_result_key_and_received {Ensure -parsekey is used as opt result and received key}\ + -setup $common -body { + set docids [list] + + set argd [punk::args::parse {-f example.txt} withdef @opts {-f|--file -parsekey -path -type string}] + lappend docids [dict get $argd id] + lappend result [dict get $argd opts] + lappend result [dict exists [dict get $argd received] -path] + lappend result [dict exists [dict get $argd received] --file] + }\ + -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } + }\ + -result [list\ + {-path example.txt} 1 0 + ] + + + test parsekey_opt_default_result_key {Ensure defaults are returned under -parsekey}\ + -setup $common -body { + set docids [list] + + set argd [punk::args::parse {} withdef @opts {-f|--file -parsekey -path -type string -default example.txt}] + lappend docids [dict get $argd id] + lappend result [dict get $argd opts] + }\ + -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } + }\ + -result [list\ + {-path example.txt} + ] + + + test parsekey_opt_shared_value_key {Ensure different opts can share a -parsekey while keeping their own validation}\ + -setup $common -body { + set docids [list] + + set argd [punk::args::parse {-xy {1 2}} withdef @opts {-xy -parsekey -coord -type list -minsize 2 -maxsize 2} {-xyz -parsekey -coord -type list -minsize 3 -maxsize 3}] + lappend docids [dict get $argd id] + lappend result [dict get $argd opts] + + set argd [punk::args::parse {-xyz {1 2 3}} withdef @opts {-xy -parsekey -coord -type list -minsize 2 -maxsize 2} {-xyz -parsekey -coord -type list -minsize 3 -maxsize 3}] + lappend docids [dict get $argd id] + lappend result [dict get $argd opts] + }\ + -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } + }\ + -result [list\ + {-coord {1 2}}\ + {-coord {1 2 3}} + ] + + + test parsekey_opt_solo_multiple_tracking {Ensure -parsekey is used for solo and multiple tracking}\ + -setup $common -body { + set docids [list] + + set argd [punk::args::parse {-v -v} withdef @opts {-v -parsekey -verbose -type none -multiple 1}] + lappend docids [dict get $argd id] + lappend result [dict get $argd opts] + lappend result [dict get $argd solos] + lappend result [dict get $argd multis] + }\ + -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } + }\ + -result [list\ + {-verbose {1 1}}\ + {-verbose -verbose}\ + {-verbose} + ] + + + + test parsekey_required_missing_reports_parsekey {Ensure missing required opts report the -parsekey}\ + -setup $common -body { + set docid ::testspace::parsekey_required_missing_reports_parsekey + set docids [list $docid] + + punk::args::define [list @id -id $docid] @opts {-xy -parsekey -coord -type list -minsize 2 -maxsize 2 -optional 0} {-xyz -parsekey -coord -type list -minsize 3 -maxsize 3} + set err [catch {punk::args::parse {} withid $docid} msg opts] + lappend result $err + lappend result [lrange [dict get $opts -errorcode] 0 2] + }\ + -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } + }\ + -result [list\ + 1\ + {PUNKARGS VALIDATION {optionmissing -coord received {}}} + ] + + + + test parsekey_required_shared_key_satisfied_by_other_opt {Ensure any opt with the same -parsekey satisfies the required key}\ + -setup $common -body { + set docids [list] + + set argd [punk::args::parse {-xyz {1 2 3}} withdef @opts {-xy -parsekey -coord -type list -minsize 2 -maxsize 2 -optional 0} {-xyz -parsekey -coord -type list -minsize 3 -maxsize 3}] + lappend docids [dict get $argd id] + lappend result [dict get $argd opts] + }\ + -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } + }\ + -result [list\ + {-coord {1 2 3}} + ] + + + test parsekey_required {test behaviour of -parsekey with -required true}\ + -setup $common -body { + set docids [list] + + #first test with no -optional flags so -coords is optional + set argd [punk::args::parse {-xy {1 2}} withdef @opts {-xy -parsekey -coord -type list -minsize 2 -maxsize 2} {-xyz -parsekey -coord -type list -minsize 3 -maxsize 3}] + lappend docids [dict get $argd id] + lappend result [dict get $argd opts] + + #the -optional 0 in the presence of -parsekey means -coord is required (not that the specific arg -xy is required) - so this should work because -xy is present and has a -parsekey of -coord + set argd [punk::args::parse {-xy {1 2}} withdef @opts {-xy -parsekey -coord -type list -minsize 2 -maxsize 2 -optional 0} {-xyz -parsekey -coord -type list -minsize 3 -maxsize 3}] + lappend docids [dict get $argd id] + lappend result [dict get $argd opts] + + + + }\ + -cleanup { + foreach id $docids { + punk::args::undefine $id 1 + } + }\ + -result [list\ + {-coord {1 2}}\ + {-coord {1 2}} + ] +} +tcltest::cleanupTests ;#needed to produce test summary line. diff --git a/src/tests/modules/punk/args/testsuites/args/synopsis.test b/src/tests/modules/punk/args/testsuites/args/synopsis.test new file mode 100644 index 00000000..b789e33a --- /dev/null +++ b/src/tests/modules/punk/args/testsuites/args/synopsis.test @@ -0,0 +1,184 @@ + +package require tcltest + +namespace eval ::testspace { + namespace import ::tcltest::* + + package require punk::args + package require punk::ansi + package require punk::ns + + + 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][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 [punk::ansi::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 [punk::ansi::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 [punk::ansi::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][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 [punk::ansi::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 + 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]\][a+ noitalic]\]"\ + {--verbose unreceived}\ + {--verbose 33}\ + expected-error1\ + {--verbose received} + ] +} +tcltest::cleanupTests ;#needed to produce test summary line. + + diff --git a/src/tests/modules/punk/path/testsuites/tests/all.tcl b/src/tests/modules/punk/path/testsuites/tests/all.tcl index 0e004025..95b6b0fb 100644 --- a/src/tests/modules/punk/path/testsuites/tests/all.tcl +++ b/src/tests/modules/punk/path/testsuites/tests/all.tcl @@ -40,4 +40,5 @@ tcltest::configure -singleproc true tcltest::configure {*}$::argv tcltest::configure -testdir $script_dir tcltest::configure -asidefromdir * ;#only the toplevel all.tcl should recurse. +puts stderr "tcltest -verbose: [tcltest::configure -verbose]" tcltest::runAllTests \ No newline at end of file diff --git a/src/tests/modules/punk/path/testsuites/tests/path.test b/src/tests/modules/punk/path/testsuites/tests/path.test index faf4702a..843e2936 100644 --- a/src/tests/modules/punk/path/testsuites/tests/path.test +++ b/src/tests/modules/punk/path/testsuites/tests/path.test @@ -471,8 +471,9 @@ namespace eval ::testspace { } expr {$results eq {1 1 1}} } \ + -constraints foobar \ -cleanup $treefilenames_cleanup \ - -result 1 + -result 1a } tcltest::cleanupTests ;#needed to produce test summary. \ No newline at end of file diff --git a/src/tests/runtests.tcl b/src/tests/runtests.tcl index 111916c9..93eb6f1a 100644 --- a/src/tests/runtests.tcl +++ b/src/tests/runtests.tcl @@ -19,107 +19,341 @@ tcl::tm::remove {*}$original_tmlist tcl::tm::add [file normalize $project_root/src/bootsupport/modules] ;#ie /src/modules tcl::tm::add [file normalize $project_root/src/bootsupport/modules_tcl$tcl_major] tcl::tm::add {*}[lreverse $original_tmlist] -set libdir [list] -set libdir [file normalize $project_root/src/bootsupport/lib] -set libvdir [file normalize $project_root/src/bootsupport/lib/tcl$tcl_major] +package require platform + +set arch [platform::generic] + +set libdir [file normalize $project_root/src/bootsupport/lib] if {$libdir ni $::auto_path} { lappend ::auto_path $libdir } -if {$libvdir ni $::auto_path} { - lappend ::auto_path $libvdir +set libdir_arch [file normalize $project_root/src/bootsupport/lib/tcl$tcl_major/$arch] +if {$libdir_arch ni $::auto_path} { + lappend ::auto_path $libdir_arch } #------------------------------------ +package require punk +package require punk::args +package require shellrun +package require punk::tcltestrun + + + + #------------------------------------ #for the tests running in child processes, -#use the unbuilt modules/libraries under development rather than the installed versions. -set tmlist [list] -lappend tmlist [file normalize $test_base/../modules] ;#ie /src/modules -lappend tmlist [file normalize $test_base/../modules_tcl$tcl_major] -set libdirs [list] -lappend libdirs [file normalize $test_base/../lib] -lappend libdirs [file normalize $test_base/../lib/tcl$tcl_major] -if {$libdir ni $::auto_path} { - lappend ::auto_path $libdir -} -if {$libvdir ni $::auto_path} { - lappend ::auto_path $libvdir -} +#use the unbuilt modules/libraries under development in preference to the installed versions. +set test_tmlist [list] +set ifneeded_script "" +lappend test_tmlist [file normalize $test_base/../modules] ;#ie /src/modules +append ifneeded_script [punk::tcltestrun::tm_path_additional_ifneeded [file normalize $test_base/../modules]] +lappend test_tmlist [file normalize $test_base/../modules_tcl$tcl_major] +append ifneeded_script [punk::tcltestrun::tm_path_additional_ifneeded [file normalize $test_base/../modules]] +lappend test_tmlist [file normalize $test_base/../bootsupport/modules] +set test_auto_path [list] +lappend test_auto_path [file normalize $test_base/../lib] +lappend test_auto_path [file normalize $test_base/../lib/tcl$tcl_major] +lappend test_auto_path [file normalize $test_base/../../lib_tcl$tcl_major/$arch] +lappend test_auto_path [info library] #------------------------------------ -package require punk -package require punk::args punk::args::define { - @id -id (script)::runtestmodules - @cmd -name runtestmodules -help\ - "Run test:: modules that support the packagetest api - (have RUN command)" - -tcltestoptions -type dict -default "" -help\ - "pairs of flags/values that will be passed to tcltest::configure before running the tests. - For example, to run tests with verbose settings: - -tcltestoptions {-verbose {body pass skip error usec}} - " - -include-paths -type list -default {**} -help\ - "list of glob patterns for paths. - Only test files under paths matching these patterns will be included. - For example, to only include test files under src/modules/test: - -include-paths {src/modules/test/**}" + @id -id (script)::runtests + @cmd -name runtests\ + -summary\ + "Run the source test suites for this project."\ + -help\ + "Run the test suites for this project. + By default, all test files under src/tests/ will be included + - but you can specify particular test files or paths to include using the arguments below. + + These tests run against the unbuilt pure-tcl modules under development rather than any installed versions + - so you can test the latest code without installing it. + + To run tests against the installed versions, see the modules/test folder within this project or + package require the approprate test:: package and call its RUN function. + " + @opts + -tcltestoptions -type dict -default {-singleproc 1 -verbose {body pass skip start error line usec}} -help\ + "Pairs of flags/values that will be passed to tcltest::configure before running the tests. + The supplied flags will be merged with the default flags." + -show-raw-output -type boolean -default 0 -help\ + "If true, the raw stdout and stderr produced by tcltest from the test files will be shown in addition to the parsed results. + This will be in markdown code blocks under headings: + stdout from + and + stderr from + " + -include-paths -type list -default {**} -help\ + "List of glob patterns for paths. + Paths are relative to the test base and should use forward slashes as separators. + + Only test files under paths matching these patterns will be included. + For example, to only include test files under /src/modules/punk + -include-paths {modules/punk/**}" @values -min 0 -max -1 - glob -type string -multiple 1 -optional 1 -help\ - " names or glob patterns of test files to run. - This matches against the file tail - so should not include path segments. - The default if not supplied is a single *.test entry. - " + glob -type string -multiple 1 -optional 1 -help\ + "Names or glob patterns of test files to run. + This matches against the file tail - so should not include path segments. + The default if not supplied is a single *.test entry." } +if {"-h" in $::argv || "--help" in $::argv || "-help" in $::argv} { + puts stderr [punk::args::usage (script)::runtests] + exit 0 +} -puts "argv: $::argv" - +#puts "argv: $::argv" -set argd [punk::args::parse $::argv withid (script)::runtestmodules] +set argd [punk::args::parse $::argv withid (script)::runtests] lassign [dict values $argd] leaders opts values received -set tcltestoptions [dict get $opts -tcltestoptions] +set opt_tcltestoptions [dict get $opts -tcltestoptions] +set default_tcltestoptions {-singleproc 1 -verbose {body pass skip start error line usec}} + +set opt_show_raw_output [dict get $opts -show-raw-output] + + set include_paths [dict get $opts -include-paths] -if {![dict exists $received glob]} { - set file_globs [list *.test] + + +set tcltestoptions [dict merge $default_tcltestoptions $opt_tcltestoptions] + +if {[dict exists $tcltestoptions -file]} { + set file_globs [dict get $tcltestoptions -file] } else { - set file_globs [dict get $values glob] + #set file_globs [list *.test] + set file_globs [list] +} + +if {[dict exists $received glob]} { + lappend file_globs [dict get $values glob] +} +#fall back to default if still empty +if {[llength $file_globs] == 0} { + set file_globs [list *.test] } -puts "tcltestoptions: $tcltestoptions" -puts "file_globs: $file_globs" -puts "test_base: $test_base" +dict set tcltestoptions -file $file_globs + + +#puts "tcltestoptions: $tcltestoptions" +#puts "file_globs: $file_globs" +#puts "test_base: $test_base" set thisexecutable [info nameofexecutable] -puts "executable: $thisexecutable" +#puts "executable: $thisexecutable" set exclude_files [list AGENTS.md *.tcl] -set testfiles [punk::path::treefilenames -dir $test_base -exclude-files $exclude_files -include-paths $include_paths $file_globs] -foreach f $testfiles { - puts "test file: $f" + +set tallydict [dict create] +dict set tallydict total 0 +dict set tallydict passed 0 +dict set tallydict skipped 0 +dict set tallydict failed 0 +dict set tallydict pkgs_with_fails [list] +dict set tallydict pkgs_without_fails [list] +dict set tallydict pkgs_with_warnings [list] + +set testfiles [punk::path::treefilenames -dir $test_base -tailbase $test_base -exclude-files $exclude_files -include-paths $include_paths $file_globs] + +if {[dict exists $tcltestoptions -singleproc] && [dict get $tcltestoptions -singleproc]} { + puts "Running tests in single process mode" + set singleproc 1 +} else { + puts "Running tests in multiple processes" + set singleproc 0 +} + +puts "---------------" +puts "test auto_path: $test_auto_path" +puts "---------------" +puts "tcltestoptions: $tcltestoptions" +foreach testfile_relative $testfiles { + set testfile [file normalize [file join $test_base $testfile_relative]] + puts stdout "" + #puts stdout "running test file $testfile" + puts stdout "## runtests $testfile_relative" + puts stdout "" + + dict set tcltestoptions -testdir [file dirname $testfile] + + if {$singleproc} { + #in single process mode we can just source the test file in an interp - but we need to set up the environment for the test file - such as the module search path to ensure it picks up the unbuilt modules under development rather than any installed versions. + interp create testinterp + testinterp eval {tcl::tm::remove [tcl::tm::list]} + testinterp eval [list tcl::tm::add {*}$test_tmlist] + testinterp eval [list set ::auto_path $test_auto_path] + testinterp eval $ifneeded_script + testinterp eval [list set ::argv $tcltestoptions] + testinterp eval [list set ::argc [llength $tcltestoptions]] + testinterp eval {package require tcltest} + testinterp eval [list tcltest::configure {*}$tcltestoptions] + testinterp eval {package require shellrun} + #puts ">>>> [testinterp eval { + # set result "" + # foreach key [tcltest::configure] { + # append result "$key: [tcltest::configure $key]\n" + # } + # return $result + # }] <<<<" + set result [testinterp eval [list shellrun::runx -tcl source $testfile]] + interp delete testinterp + puts stdout "sourced $testfile " + flush stdout + } else { + #todo - we need to set up the environment for the test file - such as the module search path to ensure it picks up the unbuilt modules under development rather than any installed versions. + #we also need to pass the tcltestoptions to the test file. + #one way would be to prepend this data to the testfiledata in a temporary file and then run that temporary file. + #Another way might be to pipe the whole script through stdin to the child process - but that may cause issues with tcltest's use of stdin for user input. + if {[catch { + set result [shellrun::runx $thisexecutable $testfile] + #set result [shellrun::runx ls] + } errM]} { + puts stderr "error calling 'runout $thisexecutable $testfile' $errM"; flush stderr + set result {none ""} + } + puts stdout "executed $thisexecutable $testfile " + puts stdout "result keys: [dict keys $result] " + flush stdout + } + + if {$opt_show_raw_output} { + puts stdout "" + puts stdout "### stdout from $testfile_relative" + puts stdout "" + puts stdout "```" + puts stdout [dict get $result stdout] + puts stdout "```" + puts stdout "" + puts stdout "### stderr from $testfile_relative" + puts stdout "" + puts stdout "```" + puts stdout [dict get $result stderr] + puts stdout "```" + puts stdout "" + } + + if {[dict exists $result error]} { + puts stderr "error running test file $testfile: [dict get $result error]" + flush stderr + dict lappend tallydict pkgs_with_fails $testfile + } else { + set resultdict [punk::tcltestrun::parse_testrun $result $testfile] + if {[dict get $resultdict summaryline_detected] == 0} { + puts stderr "WARNING: No results parsed from test file $testfile - test file may be missing tcltest::cleanupTests call" + dict lappend tallydict pkgs_with_warnings $testfile + } elseif {[dict get $resultdict summaryline_detected] > 1} { + puts stderr "WARNING: More than one summary line detected in test file $testfile - test file may be calling tcltest::cleanupTests multiple times" + dict lappend tallydict pkgs_with_warnings $testfile + } else { + dict incr tallydict total [dict get $resultdict summaryline_total] + dict incr tallydict passed [dict get $resultdict summaryline_passed] + dict incr tallydict skipped [dict get $resultdict summaryline_skipped] ;#more than just skipped due to constraints - also includes skipped due to -skip and -match values. + dict incr tallydict failed [dict get $resultdict summaryline_failed] + #puts stdout [dict get $resultdict out] + if {[dict get $resultdict summaryline_failed] > 0} { + puts stdout "test file $testfile had failures" + dict lappend tallydict pkgs_with_fails $testfile + } else { + puts stdout "test file $testfile passed" + dict lappend tallydict pkgs_without_fails $testfile + } + } + + + #puts stdout "resultdict: $resultdict" + puts stdout "" + puts stdout "### testcase passes for $testfile" + puts stdout "" + dict for {testname testdict} [dict get $resultdict testcase_passes] { + puts stdout "- testname: $testname " + if {[dict exists $testdict microseconds]} { + puts stdout " microseconds: [dict get $testdict microseconds] " + } + } + puts stdout "" + + + puts stdout "### testcase failures for $testfile" + puts stdout "" + dict for {testname testdict} [dict get $resultdict testcase_fails] { + puts stdout "- testname: $testname " + puts stdout " test_description: [dict get $testdict test_description] " + puts stdout " test_body : " + puts stdout " ```tcl" + puts stdout " [dict get $testdict test_body]" + puts stdout " ```" + puts stdout " test_status : [dict get $testdict test_status] " + if {[dict get $testdict test_status] eq "ERROR"} { + puts stdout " returncode : [dict get $testdict returncode] " + puts stdout " errorcode : [dict get $testdict errorcode] " + } + } + puts stdout "" + puts stdout "### testcase_constraintskips" + puts stdout "" + dict for {testname testdict} [dict get $resultdict testcase_constraintskips] { + puts stdout "- testname: $testname " + puts stdout " skipreason: [dict get $testdict reason] " + } + puts -nonewline stdout "\n" + flush stdout + } + + set i 0 } +puts stdout "## runtests summary" +puts stdout "" -exit 1 - -#don't package require tcltest too early or it may examine and respond to ::argv itself. (e.g to respond to --help, but we have our own help) -package require tcltest - -set ::argv $tcltestoptions -set ::argc [llength $tcltestoptions] -#set ::argv {} -#set ::argc 0 - -tcltest::configure -verbose "body pass skip error usec" -tcltest::configure -testdir $script_dir -tcltest::configure -file $file_globs -#review - single process has less isolation - but works better in this case. -#(some tclsh shells can hang when running with -singleproc false - needs investigation) -#tclte::configure -singleproc true -tcltest::configure -singleproc true -dict for {k v} $tcltestoptions { - tcltest::configure $k $v +puts stdout "### testfiles without failures" +puts stdout "" +foreach pkg [dict get $tallydict pkgs_without_fails] { + puts stdout " - $pkg" } -tcltest::runAllTests \ No newline at end of file +puts stdout "" + +puts stdout "### testfiles with failures" +puts stdout "" +foreach pkg [dict get $tallydict pkgs_with_fails] { + puts stdout " - $pkg" +} +puts stdout "" + +puts stdout "### testfiles with warnings" +puts stdout "" +foreach pkg [dict get $tallydict pkgs_with_warnings] { + puts stdout " - $pkg" +} +puts stdout "" + +puts stdout "### runtests tally" +puts stdout "" +puts stdout "Total [dict get $tallydict total] Passed [dict get $tallydict passed] Skipped [dict get $tallydict skipped] Failed [dict get $tallydict failed] " +puts stdout "" +puts stdout "runtests DONE " + +exit 0 + +##don't package require tcltest too early or it may examine and respond to ::argv itself. (e.g to respond to --help, but we have our own help) +#package require tcltest +# +#set ::argv $tcltestoptions +#set ::argc [llength $tcltestoptions] +##set ::argv {} +##set ::argc 0 +# +#tcltest::configure -verbose "body pass skip error usec" +#tcltest::configure -testdir $script_dir +#tcltest::configure -file $file_globs +##review - single process has less isolation - but works better in this case. +##(some tclsh shells can hang when running with -singleproc false - needs investigation) +##tclte::configure -singleproc true +#tcltest::configure -singleproc true +#dict for {k v} $tcltestoptions { +# tcltest::configure $k $v +#} +#tcltest::runAllTests \ No newline at end of file diff --git a/src/tests/shell/AGENTS.md b/src/tests/shell/AGENTS.md new file mode 100644 index 00000000..ad80e783 --- /dev/null +++ b/src/tests/shell/AGENTS.md @@ -0,0 +1,29 @@ +# src/tests/shell — Shell Behavior Tests + +## Purpose + +Tests for shell-level behavior, command-line execution, and stdin/stdout interaction that are not owned by a specific source module namespace. + +## Ownership + +- Agents may update this subtree when changing shell behavior, command execution, or interactive stream handling. +- Keep module API behavior tests in `src/tests/modules/` unless shell invocation is the behavior under test. + +## Local Contracts + +- Tests here may exercise process execution, stdin, stdout, stderr, and shell filtering behavior. +- Keep command inputs and expected outputs explicit so failures can be reproduced outside the aggregate runner. +- Avoid relying on installed packages or root-level build outputs unless the test explicitly targets a built executable. + +## Work Guidance + +- Use focused harness runs with `-include-paths shell/**` when editing this subtree. +- Include enough failure output to identify the launched command and stream comparison. +- Keep platform-sensitive assumptions visible in the test body. + +## Verification + +- ` src/tests/runtests.tcl -include-paths shell/**` passes for changes in this subtree. + +## Child DOX Index + diff --git a/src/tests/shell/testsuites/stdin/runstdin.test b/src/tests/shell/testsuites/stdin/runstdin.test new file mode 100644 index 00000000..9bd6685d --- /dev/null +++ b/src/tests/shell/testsuites/stdin/runstdin.test @@ -0,0 +1,34 @@ +package require tcltest + +package require punk::ns + +namespace eval ::testspace { + namespace import ::tcltest::* + variable common { + set result "" + } + + + test bench_clean {test using bench package clean result for: << exit}\ + -setup $common -body { + package require bench + + set thisexe [file normalize [info nameofexecutable]] + set tail [file tail $thisexe] + set location [file dirname $thisexe] + set located [bench::locate $tail $location] + if {$located ne ""} { + set located [file normalize $located] + } + + lappend result [string equal $located $thisexe] + + }\ + -cleanup { + }\ + -result [list\ + 1\ + ] + +} +tcltest::cleanupTests ;#needed to produce test summary. \ No newline at end of file