diff --git a/AGENTS.md b/AGENTS.md new file mode 100644 index 00000000..bdda469d --- /dev/null +++ b/AGENTS.md @@ -0,0 +1,166 @@ +# AGENTS.md + +Agent handbook for the ShellSpy (Punk Shell) repository. These guidelines cover builds, linting, testing, code style, and day-to-day conventions for all contributors and agentic assistants. Always check for nested `AGENTS.md` files before editing subdirectories—this root spec applies repo-wide unless overridden deeper in the tree. + +## Quickstart Checklist +- Confirm Windows-friendly Tcl toolchain (8.6+ required, 9.0 supported). +- Run `tclsh make.tcl` once after cloning to populate generated assets. +- Keep edits within the scoped instructions of any nested `AGENTS.md`. +- Use `tclint` before submitting code to align formatting and structure. +- Execute at least one relevant test script (`tclsh scriptlib/tests/.tcl`). +- Document changes impacting build, tooling, or developer workflow. + +## Build & Bootstrap Commands +- **Primary build**: `tclsh make.tcl` (Windows default) or `punk make.tcl` inside Punk shell. +- **Alt entry point**: `punk build.tcl` or `tclsh build.tcl` for kettle-style builds. +- **Bootstrap shell**: `pmix KettleShell` from inside Punk shell for advanced packaging tasks. +- **Clean/resync**: Remove `build/` artifacts then rerun `tclsh make.tcl`; avoid partial cleans that break boot modules. +- **Binary images**: Use `punk make.tcl --target ` when producing platform-specific bundles (see script comments for targets). + +## Testing Strategy +- **Test location**: `scriptlib/tests/` holds all Tcl test scripts; keep new tests there. +- **Run entire suite**: Iterate with `for /r scriptlib\tests %f in (*.tcl) do tclsh %f` (Windows) or a similar shell loop on POSIX. +- **Run single test**: `tclsh scriptlib/tests/.tcl` (e.g., `tclsh scriptlib/tests/json.tcl`). +- **Focused verification**: Mirror production pipelines inside tests using Punk pipeline syntax for parity. +- **Test dependencies**: Every test must `package require punk`; declare extra packages explicitly to avoid hidden dependencies. +- **Failure triage**: Capture stderr logs; prefer `try/on error` blocks inside tests for clearer diagnostics. + +## Linting & Formatting +- **Command**: `tclint` (configured via `tclint.toml` in repo root). +- **Files covered**: `.tcl`, `.tm`, `.sdc`; extend config if new extensions appear. +- **Line length**: Hard cap at 400 characters; wrap pipelines thoughtfully instead of exceeding. +- **Blank lines**: No more than 10 consecutive blanks. +- **Indentation**: 4 spaces; tabs are disallowed in Tcl sources except inside string literals. +- **Auto-fixes**: Run `tclint --fix` only when you have reviewed the resulting diff. + +## Toolchain & Dependencies +- Prefer the provided vendor modules under `src/vendor*` before fetching new dependencies. +- Use `tcl::tm::path add ` to surface project modules when writing new tooling. +- Keep compatibility with Tcl 8.6+; gate 9.0-specific features behind version checks. +- When optional compiled extensions (e.g., `twapi`, `tdom`) are necessary, guard `package require` calls with fallback messaging. + +## Repository Layout Primer +``` +src/ + bootsupport/modules/ # Early-load modules with minimal deps + modules/ # Main Punk modules (.tm) + lib/ # Classic Tcl libraries + scriptapps/ # Entry-point scripts for Punk apps + vendormodules*/ # Third-party modules bundled with repo +scriptlib/ # Shared utilities + tests +bin/ # Helper binaries/scripts +callbacks/, plugj.tcl, etc # Integration glue for host environments +src/vfs/* # Virtual file system images for builds +``` +Treat VFS directories as generated artifacts; edit them only when updating runtime payloads. + +## Imports & Package Management +- Always declare dependencies explicitly using `package require ` near file tops. +- Prefer fully-qualified namespaces when referencing external packages (`package require tcl::zlib`, `package require TclOO`). +- Organize custom modules as `namespace eval punk::` with filenames like `src/modules/punk/-.tm`. +- Use semantic versions that `package vcompare` can interpret; strip leading zeros. +- For optional features, probe with `if {[catch {package require foo}]} { ... }` and degrade gracefully. + +## Formatting & Layout Rules +- Opening braces stay on the same line for procs; multiline control structures may place braces on new lines for readability. +- Align continuations under their opening command; use explicit `\` when mapping to pipeline syntax is unclear. +- Keep pipelines readable by aligning `% var = ...` and `pipecase` segments vertically when possible. +- Document non-trivial procedures and exports with the standard header template (see below). + +## Naming Conventions +- **Procedures**: `lowercase_with_underscores` for internals, `camelCase` allowed for public APIs where existing patterns fit. +- **Variables**: `lowercase_with_underscores`; avoid single-letter names except for loop indices. +- **Namespaces**: Mirror directory structure; nested modules should reflect filesystem hierarchy. +- **Private helpers**: Prefix with `_` (e.g., `_resolve_stream`); do not export them. +- **Constants**: `UPPER_CASE_WITH_UNDERSCORES` declared via `namespace eval { variable CONSTANT value }` when practical. + +## Procedure Documentation Template +```tcl +# +# Args: +# arg1 - description +# arg2 - description +# Returns: +# Description of return value +proc procedure_name {arg1 arg2} { + # Implementation +} +``` +Update the template with concrete details whenever functions are user-facing or complex. + +## Error Handling & Logging +- Prefer `try { ... } on error {result options} { ... }` (Tcl 8.6+) for structured handling. +- Fallback pattern: + ```tcl + if {[catch {some_command} result]} { + puts stderr "Error: $result" + return -code error $result + } + ``` +- For Punk pipelines, wrap risky commands inside `pipecase` blocks and emit descriptive messages via `puts stderr` or Punk logging helpers. +- Never swallow errors silently; propagate with context so shell users see actionable details. + +## Pipeline & Functional Style Notes +- Use `% var = ...` bindings to capture intermediate values; keep names meaningful. +- `pipecase` should list specific patterns before catch-alls to avoid hidden matches. +- `fun name pattern { ... }` definitions should remain side-effect light; treat them as pure functions unless otherwise documented. +- Keep pipelines short and composable; extract into helper procs or `fun` definitions when they exceed ~10 logical steps. + +## Module Structure Expectations +```tcl +# Module description +package require + +namespace eval { + variable version + namespace export public_proc1 public_proc2 + + proc public_proc1 {args} { + # Implementation + } + + proc _private_helper {} { + # Private implementation + } +} +``` +Ensure module filenames include the version (`punk/console-0.1.1.tm`), and keep `namespace export` lists alphabetized for clarity. + +## Type & Data Handling +- Tcl is dynamically typed; emulate structural typing via argument validation at proc boundaries. +- Validate user inputs with `switch -exact`, `regexp`, or Punk pipeline predicates before mutation. +- Use dictionaries for structured data; avoid parallel lists. +- When bridging to binary data (e.g., ANSI/xbin parsing), document expected encodings and conversions. + +## Versioning & Releases +- Stick to semantic versioning (`major.minor.patch`). +- When referencing ranges, use bounded specs (e.g., `1.2.3-2.0.0`). +- Convert loose versions to bounded form in module metadata; helper utilities exist in boot modules for this purpose. +- Update `punk::libunknown` registries whenever adding/removing modules to keep discovery accurate. + +## Platform & Performance Notes +- Primary target: Windows (win32-x86_64). Validate code paths that rely on Windows-only packages. +- Secondary targets: Linux/macOS/FreeBSD; guard platform-specific calls with `if {$tcl_platform(os) eq "Windows"} {...}`. +- Favor compiled extensions (tcllibc, twapi) when available, but always provide scripted fallbacks. +- Be mindful of long-running pipelines; chunk work and avoid blocking the Punk shell UI thread. + +## Documentation & Comments +- Keep inline comments concise; describe intent, not mechanics. +- Update any relevant docs or usage notes in `scriptapps` when behavior changes. +- Mention environment variables or flags required to run new features. + +## Agent Workflow Tips +- No `.cursor/rules/`, `.cursorrules`, or `.github/copilot-instructions.md` files exist as of this update. If they appear later, integrate their instructions here. +- Always re-run `tclint` and the most specific test affected by your changes before committing. +- When touching VFS payloads, describe regeneration steps inside commit messages and this guide if persistent. +- Favor incremental commits tied to logical units of work; avoid monolithic diffs mixing tooling and feature changes. + +## Final Submission Checklist +- [ ] Nested `AGENTS.md` files checked for scope-specific rules. +- [ ] `tcllint` (and `tcllint --fix` if needed) executed with clean results. +- [ ] Relevant tests (`tclsh scriptlib/tests/.tcl`) executed and passing. +- [ ] Build step (`tclsh make.tcl`) verified when touching build-critical code. +- [ ] Documentation/comments updated for new behavior or flags. +- [ ] Diffs reviewed to ensure no stray whitespace or debugging output remains. + +Adhering to these conventions keeps the ShellSpy/Punk Shell ecosystem consistent, portable, and friendly for future agentic collaborators. Happy hacking! diff --git a/bin/getzig.cmd b/bin/getzig.cmd index 68591b2d..d3c3f7f7 100644 --- a/bin/getzig.cmd +++ b/bin/getzig.cmd @@ -432,21 +432,27 @@ SETLOCAL EnableDelayedExpansion @REM batch file library functions @GOTO :endlib -@REM padding -@REM padding -@REM padding -@REM padding +@REM padding xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +@REM padding xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx %= ---------------------------------------------------------------------- =% @rem courtesy of dbenham :: Example usage @rem call :getUniqueFile "d:\test\myFile" ".txt" myFile @rem echo myFile="%myFile%" - +@rem 2025 - wmic deprecated :/ +@rem 2025 - output of 'wmic os get localDateTime' was something like: +@rem LocalDateTime +@rem 20251015234316.777000+660 +@rem !time! has a resolution of centiseconds. As we test in a loop for file existence, that should be ok. :getUniqueFile baseName extension rtnVar -setlocal +setlocal enabledelayedexpansion :getUniqueFileLoop -for /f "skip=1" %%A in ('wmic os get localDateTime') do for %%B in (%%A) do set "rtn=%~1_%%B%~2" +set "r=!date!_!time!" +set "r=%r::=.%" +set "r=%r: =%" +set "rtn=%~1_!r!%~2" +echo "### %rtn%" if exist "%rtn%" ( goto :getUniqueFileLoop ) else ( @@ -454,6 +460,7 @@ if exist "%rtn%" ( ) endlocal & set "%~3=%rtn%" exit /b + %= ---------------------------------------------------------------------- =% @REM padding @@ -1273,13 +1280,13 @@ fi # #mkdir -p ./zig -#tarball="zig-x86_64-windows-0.15.1.zip" -#tarball="zig-x86_64-freebsd-0.15.1.tar.xz" -tarball="zig-x86_64-linux-0.15.1.tar.xz" +#tarball="zig-x86_64-windows-0.15.2.zip" +#tarball="zig-x86_64-freebsd-0.15.2.tar.xz" +tarball="zig-x86_64-linux-0.15.2.tar.xz" automation_name="punkshell+julian@precisium.com.au_target_by_latency" uristring="https://ziglang.org" -full_uristring="${uristring}/download/0.15.1/${tarball}?source=${automation_name}" +full_uristring="${uristring}/download/0.15.2/${tarball}?source=${automation_name}" echo "Unimplemented: Download from ${full_uristring} and extract manually" #wget $full_uristring -O ./zig/zig-linux-x86_64-0.10.1.tar.xz #tar -xf ./zig/zig-linux-x86_64-0.10.1.tar.xz -C ./zig --strip-components=1 @@ -1598,7 +1605,9 @@ if (-not(Test-Path -Path $toolsfolder -PathType Container)) { $zigfolder = Join-Path $toolsfolder -ChildPath "zig" $zigexe = Join-Path $zigfolder -ChildPath "zig.exe" # $releasearchive = "zig-x86_64-windows-0.15.1.zip" ;#zip on windows, tarball on every other platform -$releasearchive = "zig-x86_64-windows-0.16.0-dev.254+6dd0270a1.zip" +#$releasearchive = "zig-x86_64-windows-0.16.0-dev.254+6dd0270a1.zip" +#$releasearchive = "zig-x86_64-windows-0.16.0-dev.2193+fc517bd01.zip" +$releasearchive = "zig-x86_64-windows-0.15.2.zip" Write-Output "powershell version: $($PSVersionTable.PSVersion)" if (Get-Command $zigexe -ErrorAction SilentlyContinue) { @@ -1997,3 +2006,4 @@ no script engine should try to run me + diff --git a/src/bootsupport/modules/include_modules.config b/src/bootsupport/modules/include_modules.config index 0ea2f344..8ea31ad3 100644 --- a/src/bootsupport/modules/include_modules.config +++ b/src/bootsupport/modules/include_modules.config @@ -19,6 +19,7 @@ set bootsupport_modules [list\ src/vendormodules metaface\ src/vendormodules modpod\ src/vendormodules overtype\ + src/vendormodules packagetest\ src/vendormodules pattern\ src/vendormodules patterncmd\ src/vendormodules patternlib\ diff --git a/src/bootsupport/modules/packagetest-0.1.7.tm b/src/bootsupport/modules/packagetest-0.1.7.tm new file mode 100644 index 00000000..658d45a4 Binary files /dev/null and b/src/bootsupport/modules/packagetest-0.1.7.tm differ diff --git a/src/bootsupport/modules/patterncipher-0.1.1.tm b/src/bootsupport/modules/patterncipher-0.1.1.tm index 62b03cbc..0aa12476 100644 --- a/src/bootsupport/modules/patterncipher-0.1.1.tm +++ b/src/bootsupport/modules/patterncipher-0.1.1.tm @@ -37,7 +37,6 @@ package provide patterncipher [namespace eval patterncipher { package require ascii85 ;#tcllib package require pattern -::pattern::init ;# initialises (if not already) namespace eval ::patterncipher { namespace eval algo::txt { diff --git a/src/bootsupport/modules/punk/lib-0.1.5.tm b/src/bootsupport/modules/punk/lib-0.1.5.tm index db369f06..5138ac6d 100644 --- a/src/bootsupport/modules/punk/lib-0.1.5.tm +++ b/src/bootsupport/modules/punk/lib-0.1.5.tm @@ -2370,6 +2370,54 @@ namespace eval punk::lib { append body [info body is_list_all_ni_list2] proc is_list_all_ni_list2 {a b} $body } + proc is_cachedlist_all_ni_list {a b} { + upvar 0 ::punk::lib::caches::funcs_ni_list funcs + if {[info exists funcs($a)]} { + return [[set funcs($a)] $b] + } + set keybytes [encoding convertto utf-8 $a] + set key [binary encode base64 $keybytes] ;#one single-line base64 string + + set expression "" + foreach t $a { + #append expression "({$t} ni \$b) && " + append expression "{$t} ni \$b && " + } + set expression [string trimright $expression " &"] ;#trim trailing spaces and ampersands + proc ::punk::lib::caches::ni_list_$key {b} [string map [list @expression@ $expression] { + return [expr {@expression@}] + }] + + set funcs($a) ::punk::lib::caches::ni_list_$key + return [punk::lib::caches::ni_list_$key $b] + } + proc is_cachedlist_all_ni_list2 {a b} { + upvar 0 ::punk::lib::caches::funcs_ni_list funcs + if {[info exists funcs($a)]} { + return [[set funcs($a)] $b] + } + set keybytes [encoding convertto utf-8 $a] + set key [binary encode base64 $keybytes] ;#one single-line base64 string + + set d [dict create] + foreach x $a { + dict set d $x "" + } + #constructing a switch statement could be an option + # - but would need to avoid using escapes in order to get a jump-table + # - this would need runtime mapping of values - unlikely to be a win + proc ::punk::lib::caches::ni_list_$key {b} [string map [list @d@ $d] { + foreach x $b { + if {[::tcl::dict::exists {@d@} $x]} { + return 0 + } + } + return 1 + }] + + set funcs($a) ::punk::lib::caches::ni_list_$key + return [punk::lib::caches::ni_list_$key $b] + } namespace eval argdoc { variable PUNKARGS @@ -5389,6 +5437,10 @@ tcl::namespace::eval punk::lib::system { #[list_end] [comment {--- end definitions namespace punk::lib::system ---}] } +tcl::namespace::eval punk::lib::caches { + +} + tcl::namespace::eval punk::lib::debug { proc showdict {args} {} } diff --git a/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm index bcf2221f..59f23842 100644 --- a/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm @@ -170,7 +170,16 @@ namespace eval punk::mix::commandset::module { @values -min 1 -max 1 module -type string -help\ "Name of module, possibly including a namespace and/or version number - e.g mynamespace::mymodule-1.0" + e.g mynamespace::mymodule-1.0 + + Some templates may require a prefixing namespace in order to function + correctly. e.g punk.test module names should be of the form + test::mymodule or test::mymodule::mycomponent + where the modules under test are mymodule and mymodule::mycomponent. + For example with test module test::a::b::c + The 'pkg' and 'pkgunprefixed' placeholders (surrounded by % char) are + filled with test::a::b::c and a::b::c respectively. + " }] proc new {args} { set year [clock format [clock seconds] -format %Y] @@ -222,6 +231,9 @@ namespace eval punk::mix::commandset::module { } else { set modulename $module } + #normalize modulename to remove any leading :: in case it was supplied that way + set modulename [string trimleft $modulename :] + punk::mix::cli::lib::validate_modulename $modulename -errorprefix "punk::mix::commandset::module::new" if {[regexp {[A-Z]} $module]} { @@ -410,7 +422,11 @@ namespace eval punk::mix::commandset::module { #for now the user has the option to override any templates and remove %moduletemplate% if it is a security/privacy concern #Don't put literal %x% in the code for the commandset::module itself - to stop them being seen by layout scanner as replacable tokens - set tagnames [list moduletemplate $moduletemplate project $projectname pkg $modulename year $year license $opt_license authors $opt_authors version $infile_version] + #JJJ + set pkg_parts [punk::ns::nsparts $modulename] ;#(modulename known not to have leading :: at this point) + set pkg_unprefixed [join [lrange $pkg_parts 1 end] ::] + #pkg_unprefixed may be empty - irrelevant for most templates but not ok for punk.test template - but where to reject? review + set tagnames [list moduletemplate $moduletemplate project $projectname pkg $modulename pkgunprefixed $pkg_unprefixed year $year license $opt_license authors $opt_authors version $infile_version] set strmap [list] foreach {tag val} $tagnames { lappend strmap %$tag% $val diff --git a/src/bootsupport/modules/punk/repl-0.1.2.tm b/src/bootsupport/modules/punk/repl-0.1.2.tm index 0272500d..486720e8 100644 --- a/src/bootsupport/modules/punk/repl-0.1.2.tm +++ b/src/bootsupport/modules/punk/repl-0.1.2.tm @@ -479,7 +479,13 @@ proc repl::start {inchan args} { puts stderr "-->repl::start active on $inchan $args replthread:[thread::id] codethread:$codethread" set prompt_config [punk::repl::get_prompt_config] doprompt "P% " - chan event $inchan readable [list [namespace current]::repl_handler $inchan $prompt_config] + if {[llength $input_chunks_waiting($inchan)]} { + set readmore 0 + uplevel #0 [list [namespace current]::repl_handler $inchan $readmore $prompt_config] + #after 0 [list [namespace current]::repl_handler $inchan $readmore $prompt_config] + } + set readmore 1 + chan event $inchan readable [list [namespace current]::repl_handler $inchan $readmore $prompt_config] set reading 1 #catch { @@ -530,6 +536,22 @@ proc repl::start {inchan args} { #puts stderr "__> returning 0" return 0 } + +#put a script into the waiting buffer for evaluation +proc repl::submit {inputchan script} { + set prompt_config [punk::repl::get_prompt_config] + upvar ::punk::console::input_chunks_waiting input_chunks_waiting + if {[info exists input_chunks_waiting($inputchan)] && [llength $input_chunks_waiting($inputchan)]} { + set last [lindex $input_chunks_waiting($inputchan) end] + append last $script + lset input_chunks_waiting($inputchan) end $last + } else { + set input_chunks_waiting($inputchan) [list $script] + } + + #set readmore 0 + #after idle [list after 0 [list ::repl::repl_handler $inputchan $readmore $prompt_config]] +} proc repl::post_operations {} { if {[info exists ::repl::post_script] && [string length $::repl::post_script]} { #put aside post_script so the script has the option to add another post_script and restart the repl @@ -1384,7 +1406,10 @@ proc punk::repl::repl_handler_restorechannel_if_not_eof {inputchan previous_inpu } return [chan conf $inputchan] } -proc repl::repl_handler {inputchan prompt_config} { +proc repl::repl_handler {inputchan readmore prompt_config} { + #readmore set to zero used to process input_chunks_waiting without reading inputchan, + # and without rescheduling reader + # -- review variable in_repl_handler set in_repl_handler [list $inputchan $prompt_config] @@ -1451,115 +1476,132 @@ proc repl::repl_handler {inputchan prompt_config} { set waitingchunk [lindex $waitinglines end] # -- #set chunksize [gets $inputchan chunk] - set chunk [read $inputchan] - set chunksize [string length $chunk] - # -- - if {$chunksize > 0} { - if {[string index $chunk end] eq "\n"} { - lappend stdinlines $waitingchunk[string range $chunk 0 end-1] - #punk::console::cursorsave_move_emitblock_return 30 30 "repl_handler num_stdinlines [llength $stdinlines] chunk:$yellow[ansistring VIEW -lf 1 $chunk][a] fblocked:[fblocked $inputchan] pending:[chan pending input stdin]" - - punk::repl::repl_handler_restorechannel_if_not_eof $inputchan $original_input_conf - uplevel #0 [list repl::repl_process_data $inputchan line "" $stdinlines $prompt_config] - } else { - set input_chunks_waiting($inputchan) [list $allwaiting] - lappend input_chunks_waiting($inputchan) $chunk - } + if {!$readmore} { + set chunk "" + set chunksize 0 + uplevel #0 [list repl::repl_process_data $inputchan line "" $stdinlines $prompt_config] + set input_chunks_waiting($inputchan) [list $waitingchunk] } else { - #'chan blocked' docs state: 'Note that this only ever returns 1 when the channel has been configured to be non-blocking..' - if {[chan blocked $inputchan]} { - #REVIEW - - #todo - figure out why we're here. - #can we even put a spinner so we don't keep emitting lines? We probably can't use any ansi functions that need to get a response on stdin..(like get_cursor_pos) - #punk::console::get_size is problematic if -winsize not available on the stdout channel - which is the case for certain 8.6 versions at least.. platform variances? - ## can't do this: set screeninfo [punk::console::get_size]; lassign $screeninfo _c cols _r rows - set outconf [chan configure stdout] - set RED [punk::ansi::a+ red bold]; set RST [punk::ansi::a] - if {"windows" eq $::tcl_platform(platform)} { - set msg "${RED}$inputchan chan blocked is true. (line-length Tcl windows channel bug?)$RST \{$allwaiting\}" + set chunk [read $inputchan] + set chunksize [string length $chunk] + if {$chunksize > 0} { + if {[string index $chunk end] eq "\n"} { + lappend stdinlines $waitingchunk[string range $chunk 0 end-1] + #punk::console::cursorsave_move_emitblock_return 30 30 "repl_handler num_stdinlines [llength $stdinlines] chunk:$yellow[ansistring VIEW -lf 1 $chunk][a] fblocked:[fblocked $inputchan] pending:[chan pending input stdin]" + + punk::repl::repl_handler_restorechannel_if_not_eof $inputchan $original_input_conf + uplevel #0 [list repl::repl_process_data $inputchan line "" $stdinlines $prompt_config] } else { - set msg "${RED}$inputchan chan blocked is true.$RST \{$allwaiting\}" + set input_chunks_waiting($inputchan) [list $allwaiting] + lappend input_chunks_waiting($inputchan) $chunk } - set cols "" - set rows "" - if {[dict exists $outconf -winsize]} { - lassign [dict get $outconf -winsize] cols rows - } else { - #fallback - try external executable. Which is a bit ugly - #tput can't seem to get dimensions (on FreeBSD at least) when not run interactively - ie via exec. (always returns 80x24 no matter if run with <@stdin) - - #bizarrely - tput can work with exec on windows if it's installed e.g from msys2 - #but can be *slow* compared to unix e.g 400ms+ vs <2ms on FreeBSD ! - #stty -a is 400ms+ vs 500us+ on FreeBSD - + } else { + if {[chan blocked $inputchan]} { + #'chan blocked' docs state: 'Note that this only ever returns 1 when the channel has been configured to be non-blocking..' + #REVIEW - + #todo - figure out why we're here. + #can we even put a spinner so we don't keep emitting lines? We probably can't use any ansi functions that need to get a response on stdin..(like get_cursor_pos) + #punk::console::get_size is problematic if -winsize not available on the stdout channel - which is the case for certain 8.6 versions at least.. platform variances? + ## can't do this: set screeninfo [punk::console::get_size]; lassign $screeninfo _c cols _r rows + set outconf [chan configure stdout] + set RED [punk::ansi::a+ red bold]; set RST [punk::ansi::a] if {"windows" eq $::tcl_platform(platform)} { - set tputcmd [auto_execok tput] - if {$tputcmd ne ""} { - if {![catch {exec {*}$tputcmd cols lines} values]} { - lassign $values cols rows - } - } + set msg "${RED}$inputchan chan blocked is true. (line-length Tcl windows channel bug?)$RST \{$allwaiting\}" + } else { + set msg "${RED}$inputchan chan blocked is true.$RST \{$allwaiting\}" } + set cols "" + set rows "" + if {[dict exists $outconf -winsize]} { + lassign [dict get $outconf -winsize] cols rows + } else { + #fallback1 query terminal + if {![catch {punk::console::get_size} sdict]} { + set cols [dict get $sdict columns] + set rows [dict get $sdict rows] + } + + if {![string is integer -strict $cols] || ![string is integer -strict $rows]} { + + #fallback2 - try external executable. Which is a bit ugly + #tput can't seem to get dimensions (on FreeBSD at least) when not run interactively - ie via exec. (always returns 80x24 no matter if run with <@stdin) + + #bizarrely - tput can work with exec on windows if it's installed e.g from msys2 + #but can be *slow* compared to unix e.g 400ms+ vs <2ms on FreeBSD ! + #stty -a is 400ms+ vs 500us+ on FreeBSD - if {![string is integer -strict $cols] || ![string is integer -strict $rows]} { - #same for all platforms? tested on windows, wsl, FreeBSD - #exec stty -a gives a result on the first line like: - #speed xxxx baud; rows rr; columns cc; - #review - more robust parsing - do we know it's first line? - set sttycmd [auto_execok stty] - if {$sttycmd ne ""} { - #the more parseable: stty -g doesn't give rows/columns - if {![catch {exec {*}$sttycmd -a} result]} { - lassign [split $result \n] firstline - set lineparts [split $firstline {;}] ;#we seem to get segments that look well behaved enough to be treated as tcl lists - review - regex? - set rowinfo [lsearch -index end -inline $lineparts rows] - if {[llength $rowinfo] == 2} { - set rows [lindex $rowinfo 0] + if {"windows" eq $::tcl_platform(platform)} { + set tputcmd [auto_execok tput] + if {$tputcmd ne ""} { + if {![catch {exec {*}$tputcmd cols lines} values]} { + lassign $values cols rows + } } - set colinfo [lsearch -index end -inline $lineparts columns] - if {[llength $colinfo] == 2} { - set cols [lindex $colinfo 0] + } + + if {![string is integer -strict $cols] || ![string is integer -strict $rows]} { + #same for all platforms? tested on windows, wsl, FreeBSD + #exec stty -a gives a result on the first line like: + #speed xxxx baud; rows rr; columns cc; + #review - more robust parsing - do we know it's first line? + set sttycmd [auto_execok stty] + if {$sttycmd ne ""} { + #the more parseable: stty -g doesn't give rows/columns + if {![catch {exec {*}$sttycmd -a} result]} { + lassign [split $result \n] firstline + set lineparts [split $firstline {;}] ;#we seem to get segments that look well behaved enough to be treated as tcl lists - review - regex? + set rowinfo [lsearch -index end -inline $lineparts rows] + if {[llength $rowinfo] == 2} { + set rows [lindex $rowinfo 0] + } + set colinfo [lsearch -index end -inline $lineparts columns] + if {[llength $colinfo] == 2} { + set cols [lindex $colinfo 0] + } + } } } } } - } - if {[string is integer -strict $cols] && [string is integer -strict $rows]} { - #got_dimensions - todo - try spinner? - #puts -nonewline stdout [punk::ansi::move $rows 4]$msg - #use cursorsave_ version which avoids get_cursor_pos_list call - set msglen [ansistring length $msg] - punk::console::cursorsave_move_emitblock_return $rows [expr {$cols - $msglen -1}] $msg ;#supports also vt52 - } else { - #no mechanism to get console dimensions - #we are reduced to continuously spewing lines. - puts stderr $msg - } + if {[string is integer -strict $cols] && [string is integer -strict $rows]} { + #got_dimensions - todo - try spinner? + #puts -nonewline stdout [punk::ansi::move $rows 4]$msg + #use cursorsave_ version which avoids get_cursor_pos_list call + set msglen [ansistring length $msg] + punk::console::cursorsave_move_emitblock_return $rows [expr {$cols - $msglen -1}] $msg ;#supports also vt52 + } else { + #no mechanism to get console dimensions + #we are reduced to continuously spewing lines. + puts stderr $msg + } - after 100 + after 100 + } + set input_chunks_waiting($inputchan) [list $allwaiting] } - set input_chunks_waiting($inputchan) [list $allwaiting] } - + # -- } else { - punk::repl::repl_handler_checkchannel $inputchan - punk::repl::repl_handler_checkcontrolsignal_linemode $inputchan - # -- --- --- - #set chunksize [gets $inputchan chunk] - # -- --- --- - set chunk [read $inputchan] - set chunksize [string length $chunk] - # -- --- --- - if {$chunksize > 0} { - #punk::console::cursorsave_move_emitblock_return 35 120 "chunk: [ansistring VIEW -lf 1 "...[string range $chunk end-10 end]"]" - set ln $chunk ;#temp - #punk::console::cursorsave_move_emitblock_return 25 30 [textblock::frame -title line "[a+ green]$waitingchunk[a][a+ red][ansistring VIEW -lf 1 $ln][a+ green]pending:[chan pending input stdin][a]"] - if {[string index $ln end] eq "\n"} { - lappend stdinlines [string range $ln 0 end-1] - punk::repl::repl_handler_restorechannel_if_not_eof $inputchan $original_input_conf - uplevel #0 [list repl::repl_process_data $inputchan line "" $stdinlines $prompt_config] - } else { - lappend input_chunks_waiting($inputchan) $ln + if {$readmore} { + punk::repl::repl_handler_checkchannel $inputchan + punk::repl::repl_handler_checkcontrolsignal_linemode $inputchan + # -- --- --- + #set chunksize [gets $inputchan chunk] + # -- --- --- + set chunk [read $inputchan] + set chunksize [string length $chunk] + # -- --- --- + if {$chunksize > 0} { + #punk::console::cursorsave_move_emitblock_return 35 120 "chunk: [ansistring VIEW -lf 1 "...[string range $chunk end-10 end]"]" + set ln $chunk ;#temp + #punk::console::cursorsave_move_emitblock_return 25 30 [textblock::frame -title line "[a+ green]$waitingchunk[a][a+ red][ansistring VIEW -lf 1 $ln][a+ green]pending:[chan pending input stdin][a]"] + if {[string index $ln end] eq "\n"} { + lappend stdinlines [string range $ln 0 end-1] + punk::repl::repl_handler_restorechannel_if_not_eof $inputchan $original_input_conf + uplevel #0 [list repl::repl_process_data $inputchan line "" $stdinlines $prompt_config] + } else { + lappend input_chunks_waiting($inputchan) $ln + } } } } @@ -1582,19 +1624,21 @@ proc repl::repl_handler {inputchan prompt_config} { } if {$continue} { - if {[dict get $original_input_conf -blocking] ne "0" || [dict get $original_input_conf -translation] ne "lf"} { - chan configure $inputchan -blocking 0 - chan configure $inputchan -translation lf - } - set chunk [read $inputchan] - #we expect a chan configured with -blocking 0 to be blocked immediately after reads - #test - just bug console for now - try to understand when/how/if a non blocking read occurs. - if {![chan blocked $inputchan]} { - puts stderr "repl_handler->$inputchan not blocked after read" - } + if {$readmore} { + if {[dict get $original_input_conf -blocking] ne "0" || [dict get $original_input_conf -translation] ne "lf"} { + chan configure $inputchan -blocking 0 + chan configure $inputchan -translation lf + } + set chunk [read $inputchan] + #we expect a chan configured with -blocking 0 to be blocked immediately after reads + #test - just bug console for now - try to understand when/how/if a non blocking read occurs. + if {![chan blocked $inputchan]} { + puts stderr "repl_handler->$inputchan not blocked after read" + } - punk::repl::repl_handler_restorechannel_if_not_eof $inputchan $original_input_conf - uplevel #0 [list repl::repl_process_data $inputchan raw-read $chunk [list] $prompt_config] + punk::repl::repl_handler_restorechannel_if_not_eof $inputchan $original_input_conf + uplevel #0 [list repl::repl_process_data $inputchan raw-read $chunk [list] $prompt_config] + } while {[llength $input_chunks_waiting($inputchan)]} { set chunkzero [lpop input_chunks_waiting($inputchan) 0] if {$chunkzero eq ""} {continue} ;#why empty waiting - and is there any point passing on? @@ -1604,33 +1648,35 @@ proc repl::repl_handler {inputchan prompt_config} { } } - if {![chan eof $inputchan]} { - ################################################################################## - #Re-enable channel read handler only if no waiting chunks - must process in order - ################################################################################## - if {![llength $input_chunks_waiting($inputchan)]} { - chan event $inputchan readable [list ::repl::repl_handler $inputchan $prompt_config] + if {$readmore} { + if {![chan eof $inputchan]} { + ################################################################################## + #Re-enable channel read handler only if no waiting chunks - must process in order + ################################################################################## + if {![llength $input_chunks_waiting($inputchan)]} { + chan event $inputchan readable [list ::repl::repl_handler $inputchan $readmore $prompt_config] + } else { + #review + #puts stderr "warning: after idle re-enable repl::repl_handler in thread: [thread::id]" + after idle [list ::repl::repl_handler $inputchan $readmore $prompt_config] + } + #################################################### } else { - #review - #puts stderr "warning: after idle re-enable repl::repl_handler in thread: [thread::id]" - after idle [list ::repl::repl_handler $inputchan $prompt_config] - } - #################################################### - } else { - #repl_handler_checkchannel $inputchan - chan event $inputchan readable {} - set reading 0 - #target is the 'main' interp in codethread. - #(note bug where thread::send goes to code interp, but thread::send -async goes to main interp) - # https://core.tcl-lang.org/thread/tktview/0de73f04c7ce188b13a4 - - thread::send -async $::repl::codethread {set ::punk::repl::codethread::is_running 0} ;#to main interp of codethread - if {$::tcl_interactive} { - rputs stderr "\nrepl_handler EOF inputchannel:[chan conf $inputchan]" - #rputs stderr "\n|repl> ctrl-c EOF on $inputchan." + #repl_handler_checkchannel $inputchan + chan event $inputchan readable {} + set reading 0 + #target is the 'main' interp in codethread. + #(note bug where thread::send goes to code interp, but thread::send -async goes to main interp) + # https://core.tcl-lang.org/thread/tktview/0de73f04c7ce188b13a4 + + thread::send -async $::repl::codethread {set ::punk::repl::codethread::is_running 0} ;#to main interp of codethread + if {$::tcl_interactive} { + rputs stderr "\nrepl_handler EOF inputchannel:[chan conf $inputchan]" + #rputs stderr "\n|repl> ctrl-c EOF on $inputchan." + } + set [namespace current]::done 1 + after 1 [list repl::reopen_stdin] } - set [namespace current]::done 1 - after 1 [list repl::reopen_stdin] } set in_repl_handler [list] } diff --git a/src/bootsupport/modules/punk/repo-0.1.1.tm b/src/bootsupport/modules/punk/repo-0.1.1.tm index 5d2a2725..16f6f1cb 100644 --- a/src/bootsupport/modules/punk/repo-0.1.1.tm +++ b/src/bootsupport/modules/punk/repo-0.1.1.tm @@ -218,7 +218,7 @@ namespace eval punk::repo { if {$fossilcmd eq "commit"} { if {[llength [file split $fosroot]]} { if {[file exists [file join $fosroot src/buildsuites]]} { - puts stderr "Todo - check buildsites/suite/projects for current branch/tag and update download_and_build_config" + puts stderr "Todo - check buildsuites/suite/projects for current branch/tag and update download_and_build_config" } } } elseif {$fossilcmd in [list "info" "status"]} { diff --git a/src/bootsupport/modules/shellfilter-0.2.1.tm b/src/bootsupport/modules/shellfilter-0.2.1.tm index 8e59cf0b..2eb2f8fa 100644 --- a/src/bootsupport/modules/shellfilter-0.2.1.tm +++ b/src/bootsupport/modules/shellfilter-0.2.1.tm @@ -2472,7 +2472,14 @@ namespace eval shellfilter { set exitinfo [list error "$errMsg" errorCode $::errorCode errorInfo "$::errorInfo"] } } + #puts "shellfilter::run finished call" + #------------------------- + #warning - without flush stdout - we can get hang, but only on some terminals + # - mechanism for this problem not understood! + flush stdout + flush stderr + #------------------------- #the previous redirections on the underlying inchan/outchan/errchan items will be restored from the -aside setting during removal #Remove execution-time Tees from stack @@ -2480,6 +2487,7 @@ namespace eval shellfilter { shellfilter::stack::remove stderr $id_err #shellfilter::stack::remove stderr $id_in + #puts stderr "shellfilter::run complete..." #chan configure stderr -buffering line #flush stdout diff --git a/src/bootsupport/modules/shellrun-0.1.1.tm b/src/bootsupport/modules/shellrun-0.1.1.tm index 478c70fa..c3f7ab10 100644 --- a/src/bootsupport/modules/shellrun-0.1.1.tm +++ b/src/bootsupport/modules/shellrun-0.1.1.tm @@ -187,10 +187,10 @@ namespace eval shellrun { #--------------------------------------------------------------------------------------------- set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none ] #--------------------------------------------------------------------------------------------- - foreach id $idlist_stderr { shellfilter::stack::remove stderr $id } + #puts stderr "shellrun::run exitinfo: $exitinfo" flush stderr flush stdout diff --git a/src/bootsupport/modules/test/tomlish-1.1.5.tm b/src/bootsupport/modules/test/tomlish-1.1.5.tm index 3ae60d42..f4f2b484 100644 Binary files a/src/bootsupport/modules/test/tomlish-1.1.5.tm and b/src/bootsupport/modules/test/tomlish-1.1.5.tm differ diff --git a/src/lib/app-punkshell/punkshell.tcl b/src/lib/app-punkshell/punkshell.tcl index bf35cbab..98798f45 100644 --- a/src/lib/app-punkshell/punkshell.tcl +++ b/src/lib/app-punkshell/punkshell.tcl @@ -95,11 +95,11 @@ dict with prevglobal {} dict set params -readprocesstranslation crlf dict set params -outtranslation lf - set id_err [shellfilter::stack::add stderr ansiwrap -action sink-locked -settings {-colour {red bold}}] + #set id_err [shellfilter::stack::add stderr ansiwrap -action sink-locked -settings {-colour {red bold}}] set exitinfo [shellfilter::run $script {*}$params] - shellfilter::stack::remove stderr $id_err + #shellfilter::stack::remove stderr $id_err if {[dict exists $exitinfo errorInfo]} { #strip out the irrelevant info from the errorInfo - we don't want info beyond 'invoked from within' as this is just plumbing related to the script sourcing @@ -346,9 +346,11 @@ dict with prevglobal {} } default { puts stderr "unrecognised script extension" + flush stderr } } - + flush stderr + flush stdout catch { shellfilter::stack::remove stderr $chanstack_stderr_redir shellfilter::stack::remove stdout $chanstack_stdout_redir diff --git a/src/lib/app-shellspy/shellspy.tcl b/src/lib/app-shellspy/shellspy.tcl index 7c4a3044..6d86b29c 100644 --- a/src/lib/app-shellspy/shellspy.tcl +++ b/src/lib/app-shellspy/shellspy.tcl @@ -808,29 +808,36 @@ set ::argv [list %a%] set ::argc [llength $::argv] set ::argv0 $normscript info script $normscript -source $normscript +source $normscript #restore values -info script $prevscript +info script $prevscript dict with prevglobal {} - }] + }] set repl_lines "" #append repl_lines {puts stderr "starting repl [chan names]"} \n #append repl_lines {puts stderr "stdin [chan configure stdin]"} \n - append repl_lines {package require punk::repl} \n - append repl_lines {repl::init -safe 0} \n - append repl_lines {repl::start stdin} \n - #append repl_lines {puts stdout "shutdown message"} \n + if {$replwhen eq "repl_first"} { #we need to cooperate with the repl to get the script to run on exit namespace eval ::repl {} set ::repl::post_script $script + + append repl_lines {package require punk::repl} \n + append repl_lines {repl::init -safe 0} \n + append repl_lines {repl::start stdin} \n set script "$repl_lines" } elseif {$replwhen eq "repl_last"} { - append script $repl_lines + append repl_lines {package require punk::repl} \n + append repl_lines {repl::init -safe 0} \n + append repl_lines [list repl::submit stdin "eval \{ $script \};\n"] \n + append repl_lines {repl::start stdin} \n + + #append script $repl_lines + set script $repl_lines } else { #just the script } diff --git a/src/modules/punk/lib-999999.0a1.0.tm b/src/modules/punk/lib-999999.0a1.0.tm index 33ec32f1..97cb9ada 100644 --- a/src/modules/punk/lib-999999.0a1.0.tm +++ b/src/modules/punk/lib-999999.0a1.0.tm @@ -2370,6 +2370,54 @@ namespace eval punk::lib { append body [info body is_list_all_ni_list2] proc is_list_all_ni_list2 {a b} $body } + proc is_cachedlist_all_ni_list {a b} { + upvar 0 ::punk::lib::caches::funcs_ni_list funcs + if {[info exists funcs($a)]} { + return [[set funcs($a)] $b] + } + set keybytes [encoding convertto utf-8 $a] + set key [binary encode base64 $keybytes] ;#one single-line base64 string + + set expression "" + foreach t $a { + #append expression "({$t} ni \$b) && " + append expression "{$t} ni \$b && " + } + set expression [string trimright $expression " &"] ;#trim trailing spaces and ampersands + proc ::punk::lib::caches::ni_list_$key {b} [string map [list @expression@ $expression] { + return [expr {@expression@}] + }] + + set funcs($a) ::punk::lib::caches::ni_list_$key + return [punk::lib::caches::ni_list_$key $b] + } + proc is_cachedlist_all_ni_list2 {a b} { + upvar 0 ::punk::lib::caches::funcs_ni_list funcs + if {[info exists funcs($a)]} { + return [[set funcs($a)] $b] + } + set keybytes [encoding convertto utf-8 $a] + set key [binary encode base64 $keybytes] ;#one single-line base64 string + + set d [dict create] + foreach x $a { + dict set d $x "" + } + #constructing a switch statement could be an option + # - but would need to avoid using escapes in order to get a jump-table + # - this would need runtime mapping of values - unlikely to be a win + proc ::punk::lib::caches::ni_list_$key {b} [string map [list @d@ $d] { + foreach x $b { + if {[::tcl::dict::exists {@d@} $x]} { + return 0 + } + } + return 1 + }] + + set funcs($a) ::punk::lib::caches::ni_list_$key + return [punk::lib::caches::ni_list_$key $b] + } namespace eval argdoc { variable PUNKARGS @@ -5389,6 +5437,10 @@ tcl::namespace::eval punk::lib::system { #[list_end] [comment {--- end definitions namespace punk::lib::system ---}] } +tcl::namespace::eval punk::lib::caches { + +} + tcl::namespace::eval punk::lib::debug { proc showdict {args} {} } diff --git a/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/modules/template_module-0.0.4.tm b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/modules/template_module-0.0.4.tm index cad941f9..688399b6 100644 --- a/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/modules/template_module-0.0.4.tm +++ b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/modules/template_module-0.0.4.tm @@ -151,11 +151,11 @@ namespace eval ::punk::args::register { # ----------------------------------------------------------------------------- # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready package provide %pkg% [tcl::namespace::eval %pkg% { variable pkg %pkg% variable version set version 999999.0a1.0 }] +## Ready return diff --git a/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/modules/template_test-0.0.1.tm b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/modules/template_test-0.0.1.tm new file mode 100644 index 00000000..82f11089 --- /dev/null +++ b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/modules/template_test-0.0.1.tm @@ -0,0 +1,139 @@ + -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2025 +# +# @@ Meta Begin +# Application %pkg% 999999.0a1.0 +# Meta platform tcl +# Meta license MIT +# @@ Meta End + +package require Tcl 8.6- + +tcl::namespace::eval %pkg% { + variable PUNKARGS + variable pkg %pkg% + variable version + set version 999999.0a1.0 + + package require packagetest + packagetest::makeAPI %pkg% $version %pkgunprefixed%; #will package provide %pkg% $version + package forget %pkgunprefixed% + package require %pkgunprefixed% +} + + +# == === === === === === === === === === === === === === === +# Sample 'about' function with punk::args documentation +# == === === === === === === === === === === === === === === +tcl::namespace::eval %pkg% { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + variable PUNKARGS + variable PUNKARGS_aliases + + lappend PUNKARGS [list { + @id -id "(package)%pkg%" + @package -name "%pkg%" -help\ + "Test suites for %pkgunprefixed% module" + }] + + namespace eval argdoc { + #namespace for custom argument documentation + proc package_name {} { + return %pkg% + } + proc about_topics {} { + #info commands results are returned in an arbitrary order (like array keys) + set topic_funs [info commands [namespace current]::get_topic_*] + set about_topics [list] + foreach f $topic_funs { + set tail [namespace tail $f] + lappend about_topics [string range $tail [string length get_topic_] end] + } + #Adjust this function or 'default_topics' if a different order is required + return [lsort $about_topics] + } + proc default_topics {} {return [list Description *]} + + # ------------------------------------------------------------- + # get_topic_ functions add more to auto-include in about topics + # ------------------------------------------------------------- + proc get_topic_Description {} { + punk::args::lib::tstr [string trim { + package %pkg% + test suite for %pkgunprefixed% module + } \n] + } + proc get_topic_License {} { + return "MIT" + } + proc get_topic_Version {} { + return "$::%pkg%::version" + } + proc get_topic_Contributors {} { + set authors {{ Julian Noble}} + set contributors "" + foreach a $authors { + append contributors $a \n + } + if {[string index $contributors end] eq "\n"} { + set contributors [string range $contributors 0 end-1] + } + return $contributors + } + proc get_topic_custom-topic {} { + punk::args::lib::tstr -return string { + A custom + topic + etc + } + } + # ------------------------------------------------------------- + } + + # we re-use the argument definition from punk::args::standard_about and override some items + set overrides [dict create] + dict set overrides @id -id "::%pkg%::about" + dict set overrides @cmd -name "%pkg%::about" + dict set overrides @cmd -help [string trim [punk::args::lib::tstr { + About %pkg% module + }] \n] + dict set overrides topic -choices [list {*}[%pkg%::argdoc::about_topics] *] + dict set overrides topic -choicerestricted 1 + dict set overrides topic -default [%pkg%::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict + set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] + lappend PUNKARGS [list $newdef] + proc about {args} { + package require punk::args + #standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on + set argd [punk::args::parse $args withid ::%pkg%::about] + lassign [dict values $argd] _leaders opts values _received + punk::args::package::standard_about -package_about_namespace ::%pkg%::argdoc {*}$opts {*}[dict get $values topic] + } +} +# end of sample 'about' function +# == === === === === === === === === === === === === === === + +# ----------------------------------------------------------------------------- +# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked +# ----------------------------------------------------------------------------- +# variable PUNKARGS +# variable PUNKARGS_aliases +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::%pkg% +} +# ----------------------------------------------------------------------------- + +package provide %pkg% [tcl::namespace::eval %pkg% { + variable pkg %pkg% + variable version + set version 999999.0a1.0 +}] +## Ready +return diff --git a/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/utility/scriptappwrappers/multishell.cmd b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/utility/scriptappwrappers/multishell.cmd index dbe4c1d4..abed8cf5 100644 --- a/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/utility/scriptappwrappers/multishell.cmd +++ b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/utility/scriptappwrappers/multishell.cmd @@ -432,10 +432,8 @@ SETLOCAL EnableDelayedExpansion @REM batch file library functions @GOTO :endlib -@REM padding -@REM padding -@REM padding -@REM padding +@REM padding xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +@REM padding xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx %= ---------------------------------------------------------------------- =% @rem courtesy of dbenham @@ -1617,3 +1615,4 @@ no script engine should try to run me #> + diff --git a/src/modules/punk/mix/commandset/module-999999.0a1.0.tm b/src/modules/punk/mix/commandset/module-999999.0a1.0.tm index 011ae58e..39819b6a 100644 --- a/src/modules/punk/mix/commandset/module-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/module-999999.0a1.0.tm @@ -170,7 +170,16 @@ namespace eval punk::mix::commandset::module { @values -min 1 -max 1 module -type string -help\ "Name of module, possibly including a namespace and/or version number - e.g mynamespace::mymodule-1.0" + e.g mynamespace::mymodule-1.0 + + Some templates may require a prefixing namespace in order to function + correctly. e.g punk.test module names should be of the form + test::mymodule or test::mymodule::mycomponent + where the modules under test are mymodule and mymodule::mycomponent. + For example with test module test::a::b::c + The 'pkg' and 'pkgunprefixed' placeholders (surrounded by % char) are + filled with test::a::b::c and a::b::c respectively. + " }] proc new {args} { set year [clock format [clock seconds] -format %Y] @@ -222,6 +231,9 @@ namespace eval punk::mix::commandset::module { } else { set modulename $module } + #normalize modulename to remove any leading :: in case it was supplied that way + set modulename [string trimleft $modulename :] + punk::mix::cli::lib::validate_modulename $modulename -errorprefix "punk::mix::commandset::module::new" if {[regexp {[A-Z]} $module]} { @@ -410,7 +422,11 @@ namespace eval punk::mix::commandset::module { #for now the user has the option to override any templates and remove %moduletemplate% if it is a security/privacy concern #Don't put literal %x% in the code for the commandset::module itself - to stop them being seen by layout scanner as replacable tokens - set tagnames [list moduletemplate $moduletemplate project $projectname pkg $modulename year $year license $opt_license authors $opt_authors version $infile_version] + #JJJ + set pkg_parts [punk::ns::nsparts $modulename] ;#(modulename known not to have leading :: at this point) + set pkg_unprefixed [join [lrange $pkg_parts 1 end] ::] + #pkg_unprefixed may be empty - irrelevant for most templates but not ok for punk.test template - but where to reject? review + set tagnames [list moduletemplate $moduletemplate project $projectname pkg $modulename pkgunprefixed $pkg_unprefixed year $year license $opt_license authors $opt_authors version $infile_version] set strmap [list] foreach {tag val} $tagnames { lappend strmap %$tag% $val diff --git a/src/modules/punk/net/vxlan-999999.0a1.0.tm b/src/modules/punk/net/vxlan-999999.0a1.0.tm new file mode 100644 index 00000000..f1598682 --- /dev/null +++ b/src/modules/punk/net/vxlan-999999.0a1.0.tm @@ -0,0 +1,365 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.4.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2026 +# +# @@ Meta Begin +# Application punk::net::vxlan 999999.0a1.0 +# Meta platform tcl +# Meta license MIT +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +package require Tcl 8.6- + + + +tcl::namespace::eval punk::net::vxlan { + variable PUNKARGS + + #todo - ipv6 - rename functions ipv4_vni_to_mcast ipv6_vni_to_mcast etc? + #IPv6 uses FF00::/8 + + lappend PUNKARGS [list { + @id -id "::punk::net::vxlan::vni_to_mcast" + @cmd -name "punk::net::vxlan::vni_to_mcast" -help\ + "Map a VXLAN VNI to a unique multicast address. + + The entire IPv4 multicast range is 224.0.0.0 - 239.255.255.255, + The upper end 239.0.0.0 - 239.255.255.255 is classified by + IANA as 'administratively scoped' (RFC 2365). + + The 239.0.0.0/8 range is 24 bits and *may* be available for VXLANs. + vni_to_mcast will map the VNI into an address in this /8 range. + + The range 239.192.0.0/14 is defined by RFC 2365 to be the + 'IPv4 Organization Local Scope' and it may be desirable to use + mappings that fall only within this range. + + Some vendors put restrictions on acceptable VNI values e.g + Cisco supports VNI values from 4096 to 16,777,215. + + 2 ranges within 239.0.0.0/8 are best avoided if it is desired + to reduce flooding by layer 2 switches and possible additional + processor load at VTEPs. + These are: + 239.0.0.0/24 (VNI 0 - 255) + and + 239.128.0.0/24 (VNI 8388608 - 8388863) + These happen to map to the same MAC address range (01:00:5e:00:00:xx) + as multicast addresses in the Link-Local Block (224.0.0.0/24) + These are commonly flooded to all ports on the switch even when IGMP + snooping is enabled (protocols such as OSPF would break if such flooding + wasn't done, as IGMP Membership Reports are normally not sent for multicast + traffic in the Link-Local Block). + " + @leaders -min 0 -max 0 + @opts -min 0 -max 0 + @values -min 1 -max 1 + vni -type integer -range {0 16777215} -help\ + "Integer representing a 24 bit VNI" + }] + proc vni_to_mcast {vni} { + if {![string is integer -strict $vni] || $vni < 0 || $vni > (2**24-1)} { + error "vni_to_mcast: VNI must be a 24bit integer i.e the range is 0 to 16777215" + } + set hex6 [format %6.6llx $vni] + set mcast "239." + foreach {h1 h2} [split $hex6 ""] { + append mcast [scan $h1$h2 %llx] . + } + set mcast [string range $mcast 0 end-1] + return $mcast + } + lappend PUNKARGS [list { + @id -id "::punk::net::vxlan::mcast_to_vni" + @cmd -name "punk::net::vxlan::mcast_to_vni" -help\ + "Return an integer VNI in the range 0 to 16777215" + @leaders -min 0 -max 0 + @opts -min 0 -max 0 + @values -min 1 -max 1 + mcastaddress -type string -help\ + "Multicast address within the 239.0.0.0/8 range. + See vni_to_mcast for notes about possible values + within the range to avoid." + }] + proc mcast_to_vni {mcastaddress} { + #todo - validate ipv4 + set addrparts [split $mcastaddress .] + set tailparts [lassign $addrparts p1] + if {$p1 ne "239"} { + error "mcast_to_vni: mcastaddress must be of the form 239.x.x.x" + } + #e.g mcastaddress: 239.188.97.78 + set hex "" + foreach tp $tailparts { + append hex [format %2.2llx $tp] + } + #e.g hex: bc614e + #e.g return: 12345678 + return [scan $hex %llx] + } + + #reference + #https://networklessons.com/multicast/multicast-ip-address-to-mac-address-mapping + + lappend PUNKARGS [list { + @id -id "::punk::net::vxlan::mcast_to_mac" + @cmd -name "punk::net::vxlan::mcast_to_mac" -help\ + "Return the MAC address this IPv4 multicast address + maps to. + Note that there will be a total of 32 addresses that + map to this same MAC address. + (see mac_to_mcast_list)" + @leaders -min 0 -max 0 + @opts -min 0 -max 0 + @values -min 1 -max 1 + mcastaddress -type string -help\ + "Multicast IPv4 address. + 224.0.0.0 to 239.255.255.255 + (224.0.0.0/4" + }] + proc mcast_to_mac {mcastaddress} { + set mac "01:00:5e:" ;#prefix for IANA reserved OUI covering the first 24 bits of 48bit mac address + #we can only use the last 23 bits from the mcastaddress + set addrparts [split $mcastaddress .] + set tailbin "" ;#binary representation of last 3 dotted parts + set p1 [lindex $addrparts 0] + if {$p1 < 224 || $p1 > 239} { + error "mcast_to_mac: address $mcastaddress does not seem to be an IPv4 multicast address" + } + foreach p [lrange $addrparts 1 end] { + append tailbin [format %8.8b $p] + } + # + set last23bits [string range $tailbin 1 end] + set tailbits "0$last23bits" + foreach {b0 b1 b2 b3 b4 b5 b6 b7} [split $tailbits ""] { + set nibble1 [scan $b0$b1$b2$b3 %b] + set nibble2 [scan $b4$b5$b6$b7 %b] + append mac "[format %x $nibble1][format %x $nibble2]:" + } + set mac [string range $mac 0 end-1] + #e.g mcastaddress: 224.132.6.17 + #result: 01:00:5e:04:06:11 + return $mac + } + #This is not a unique mapping there is 1:32 overlap + #because 5 bits are lost in the mapping + #ie there 32 multicast addresses mapping to the same mac + lappend PUNKARGS [list { + @id -id "::punk::net::vxlan::mac_to_mcast_list" + @cmd -name "punk::net::vxlan::mac_to_mcast_list" -help\ + "Return a list of the 32 multicast IPv4 addresses that + correspond to a multicast MAC address. + This is not a unique mapping because 5 bits are lost in + the process. + If a host is on a network with a lot of multicast traffic in + groups that happen to overlap with the same multicast address to MAC + mapping - there may be some additional overhead in ignoring non-relevant + frames." + @leaders -min 0 -max 0 + @opts -min 0 -max 0 + @values -min 1 -max 1 + mac -type string -help\ + "Mac address in the form 01:00:5e:xx:xx:xx or 01005exxxxxx. + The prefix 01:00:5e is the IANA reserved OUI for multicast MAC addresses. + (upper case versions of hex are also accepted)" + }] + proc mac_to_mcast_list {mac} { + #e.g 01:00:5e:0b:01:02 or 01005e0b0101 + #set bin_OUI "00000010000000001011110" + if {[string is xdigit -strict $mac] && [string length $mac] == 12} { + set mac_oui [string range $mac 0 5] + set mactailhex [string range $mac 6 end] + } else { + if {[string first : $mac] >=0} { + set macparts [split $mac :] + if {[llength $macparts] != 6} { + error "mac_to_mcast_list: mac address must have 6 parts (48bit mac address)" + } + set mac_oui [join [lrange $macparts 0 2] ""] + set mactailhex [join [lrange $macparts 3 end] ""] + } else { + error "mac_to_mcast_list: mac address must be in the form 01:00:5e:xx:xx:xx or 01005exxxxxx" + } + } + if {![string match -nocase 01005e* $mac_oui]} { + error "mac_to_mcast_list: mac address must begin with the reserved OUI 01:00:5e (or 01005e) for multicast adddresses" + } + set bin_tail "" + catch { + foreach hexdigit [split $mactailhex ""] { + set dec [scan $hexdigit %llx] + append bin_tail [format %4.4b $dec] + } + } + set last23bits [string range $bin_tail 1 end] + if {[string length $last23bits] != 23} { + error "mac_to_mcast_list: failed to convert mac:$mac to binary - check it is a properly formatted mac address" + } + #consider bytes b0 b1 b2 b3 + #last 2 bytes (b2, b3) will be the same for each resulting address + set last16bits [string range $last23bits 7 end] + set b2 [string range $last16bits 0 7] + set b3 [string range $last16bits 8 end] + set a2 [scan $b2 %b] + set a3 [scan $b3 %b] + + set top7of23 [string range $last23bits 0 6] + #first 2 bytes are 1110xxxx xnnnnnnn where the 7 n bits are the first 7 of the 23bits used from the tail, giving 32 possible values + set mcast_list [list] + for {set i 0} {$i <=31} {incr i} { + set varbits [format %5.5b $i] + set first2bytesbin "1110$varbits$top7of23" + set b0 [string range $first2bytesbin 0 7] + set b1 [string range $first2bytesbin 8 end] + lappend mcast_list "[scan $b0 %b].[scan $b1 %b].$a2.$a3" + } + if {[llength $mcast_list] != 32} { + error "mac_to_mcast_list: failed to properly calculate the 32 corresponding multicast addresses (length [llength $mcast_list] should be 32)" + } + return $mcast_list + } + +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::net::vxlan::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +#tcl::namespace::eval punk::net::vxlan::system { +#} + + +# == === === === === === === === === === === === === === === +# Sample 'about' function with punk::args documentation +# == === === === === === === === === === === === === === === +tcl::namespace::eval punk::net::vxlan { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + variable PUNKARGS + variable PUNKARGS_aliases + + lappend PUNKARGS [list { + @id -id "(package)punk::net::vxlan" + @package -name "punk::net::vxlan" -help\ + "Package + Description" + }] + + namespace eval argdoc { + #namespace for custom argument documentation + proc package_name {} { + return punk::net::vxlan + } + proc about_topics {} { + #info commands results are returned in an arbitrary order (like array keys) + set topic_funs [info commands [namespace current]::get_topic_*] + set about_topics [list] + foreach f $topic_funs { + set tail [namespace tail $f] + lappend about_topics [string range $tail [string length get_topic_] end] + } + #Adjust this function or 'default_topics' if a different order is required + return [lsort $about_topics] + } + proc default_topics {} {return [list Description *]} + + # ------------------------------------------------------------- + # get_topic_ functions add more to auto-include in about topics + # ------------------------------------------------------------- + proc get_topic_Description {} { + punk::args::lib::tstr [string trim { + package punk::net::vxlan + description to come.. + } \n] + } + proc get_topic_License {} { + return "MIT" + } + proc get_topic_Version {} { + return "$::punk::net::vxlan::version" + } + proc get_topic_Contributors {} { + set authors {{"Julian Noble" }} + set contributors "" + foreach a $authors { + append contributors $a \n + } + if {[string index $contributors end] eq "\n"} { + set contributors [string range $contributors 0 end-1] + } + return $contributors + } + proc get_topic_custom-topic {} { + punk::args::lib::tstr -return string { + A custom + topic + etc + } + } + # ------------------------------------------------------------- + } + + # we re-use the argument definition from punk::args::standard_about and override some items + set overrides [dict create] + dict set overrides @id -id "::punk::net::vxlan::about" + dict set overrides @cmd -name "punk::net::vxlan::about" + dict set overrides @cmd -help [string trim [punk::args::lib::tstr { + About punk::net::vxlan + }] \n] + dict set overrides topic -choices [list {*}[punk::net::vxlan::argdoc::about_topics] *] + dict set overrides topic -choicerestricted 1 + dict set overrides topic -default [punk::net::vxlan::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict + set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] + lappend PUNKARGS [list $newdef] + proc about {args} { + package require punk::args + #standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on + set argd [punk::args::parse $args withid ::punk::net::vxlan::about] + lassign [dict values $argd] _leaders opts values _received + punk::args::package::standard_about -package_about_namespace ::punk::net::vxlan::argdoc {*}$opts {*}[dict get $values topic] + } +} +# end of sample 'about' function +# == === === === === === === === === === === === === === === + + +# ----------------------------------------------------------------------------- +# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked +# ----------------------------------------------------------------------------- +# variable PUNKARGS +# variable PUNKARGS_aliases +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punk::net::vxlan +} +# ----------------------------------------------------------------------------- + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::net::vxlan [tcl::namespace::eval punk::net::vxlan { + variable pkg punk::net::vxlan + variable version + set version 999999.0a1.0 +}] +return + diff --git a/src/modules/punk/net/vxlan-buildversion.txt b/src/modules/punk/net/vxlan-buildversion.txt new file mode 100644 index 00000000..f47d01c8 --- /dev/null +++ b/src/modules/punk/net/vxlan-buildversion.txt @@ -0,0 +1,3 @@ +0.1.0 +#First line must be a semantic version number +#all other lines are ignored. diff --git a/src/modules/punk/repl-999999.0a1.0.tm b/src/modules/punk/repl-999999.0a1.0.tm index e9ce7aef..efe4b7dd 100644 --- a/src/modules/punk/repl-999999.0a1.0.tm +++ b/src/modules/punk/repl-999999.0a1.0.tm @@ -479,7 +479,13 @@ proc repl::start {inchan args} { puts stderr "-->repl::start active on $inchan $args replthread:[thread::id] codethread:$codethread" set prompt_config [punk::repl::get_prompt_config] doprompt "P% " - chan event $inchan readable [list [namespace current]::repl_handler $inchan $prompt_config] + if {[llength $input_chunks_waiting($inchan)]} { + set readmore 0 + uplevel #0 [list [namespace current]::repl_handler $inchan $readmore $prompt_config] + #after 0 [list [namespace current]::repl_handler $inchan $readmore $prompt_config] + } + set readmore 1 + chan event $inchan readable [list [namespace current]::repl_handler $inchan $readmore $prompt_config] set reading 1 #catch { @@ -530,6 +536,22 @@ proc repl::start {inchan args} { #puts stderr "__> returning 0" return 0 } + +#put a script into the waiting buffer for evaluation +proc repl::submit {inputchan script} { + set prompt_config [punk::repl::get_prompt_config] + upvar ::punk::console::input_chunks_waiting input_chunks_waiting + if {[info exists input_chunks_waiting($inputchan)] && [llength $input_chunks_waiting($inputchan)]} { + set last [lindex $input_chunks_waiting($inputchan) end] + append last $script + lset input_chunks_waiting($inputchan) end $last + } else { + set input_chunks_waiting($inputchan) [list $script] + } + + #set readmore 0 + #after idle [list after 0 [list ::repl::repl_handler $inputchan $readmore $prompt_config]] +} proc repl::post_operations {} { if {[info exists ::repl::post_script] && [string length $::repl::post_script]} { #put aside post_script so the script has the option to add another post_script and restart the repl @@ -1384,7 +1406,10 @@ proc punk::repl::repl_handler_restorechannel_if_not_eof {inputchan previous_inpu } return [chan conf $inputchan] } -proc repl::repl_handler {inputchan prompt_config} { +proc repl::repl_handler {inputchan readmore prompt_config} { + #readmore set to zero used to process input_chunks_waiting without reading inputchan, + # and without rescheduling reader + # -- review variable in_repl_handler set in_repl_handler [list $inputchan $prompt_config] @@ -1451,115 +1476,132 @@ proc repl::repl_handler {inputchan prompt_config} { set waitingchunk [lindex $waitinglines end] # -- #set chunksize [gets $inputchan chunk] - set chunk [read $inputchan] - set chunksize [string length $chunk] - # -- - if {$chunksize > 0} { - if {[string index $chunk end] eq "\n"} { - lappend stdinlines $waitingchunk[string range $chunk 0 end-1] - #punk::console::cursorsave_move_emitblock_return 30 30 "repl_handler num_stdinlines [llength $stdinlines] chunk:$yellow[ansistring VIEW -lf 1 $chunk][a] fblocked:[fblocked $inputchan] pending:[chan pending input stdin]" - - punk::repl::repl_handler_restorechannel_if_not_eof $inputchan $original_input_conf - uplevel #0 [list repl::repl_process_data $inputchan line "" $stdinlines $prompt_config] - } else { - set input_chunks_waiting($inputchan) [list $allwaiting] - lappend input_chunks_waiting($inputchan) $chunk - } + if {!$readmore} { + set chunk "" + set chunksize 0 + uplevel #0 [list repl::repl_process_data $inputchan line "" $stdinlines $prompt_config] + set input_chunks_waiting($inputchan) [list $waitingchunk] } else { - #'chan blocked' docs state: 'Note that this only ever returns 1 when the channel has been configured to be non-blocking..' - if {[chan blocked $inputchan]} { - #REVIEW - - #todo - figure out why we're here. - #can we even put a spinner so we don't keep emitting lines? We probably can't use any ansi functions that need to get a response on stdin..(like get_cursor_pos) - #punk::console::get_size is problematic if -winsize not available on the stdout channel - which is the case for certain 8.6 versions at least.. platform variances? - ## can't do this: set screeninfo [punk::console::get_size]; lassign $screeninfo _c cols _r rows - set outconf [chan configure stdout] - set RED [punk::ansi::a+ red bold]; set RST [punk::ansi::a] - if {"windows" eq $::tcl_platform(platform)} { - set msg "${RED}$inputchan chan blocked is true. (line-length Tcl windows channel bug?)$RST \{$allwaiting\}" + set chunk [read $inputchan] + set chunksize [string length $chunk] + if {$chunksize > 0} { + if {[string index $chunk end] eq "\n"} { + lappend stdinlines $waitingchunk[string range $chunk 0 end-1] + #punk::console::cursorsave_move_emitblock_return 30 30 "repl_handler num_stdinlines [llength $stdinlines] chunk:$yellow[ansistring VIEW -lf 1 $chunk][a] fblocked:[fblocked $inputchan] pending:[chan pending input stdin]" + + punk::repl::repl_handler_restorechannel_if_not_eof $inputchan $original_input_conf + uplevel #0 [list repl::repl_process_data $inputchan line "" $stdinlines $prompt_config] } else { - set msg "${RED}$inputchan chan blocked is true.$RST \{$allwaiting\}" + set input_chunks_waiting($inputchan) [list $allwaiting] + lappend input_chunks_waiting($inputchan) $chunk } - set cols "" - set rows "" - if {[dict exists $outconf -winsize]} { - lassign [dict get $outconf -winsize] cols rows - } else { - #fallback - try external executable. Which is a bit ugly - #tput can't seem to get dimensions (on FreeBSD at least) when not run interactively - ie via exec. (always returns 80x24 no matter if run with <@stdin) - - #bizarrely - tput can work with exec on windows if it's installed e.g from msys2 - #but can be *slow* compared to unix e.g 400ms+ vs <2ms on FreeBSD ! - #stty -a is 400ms+ vs 500us+ on FreeBSD - + } else { + if {[chan blocked $inputchan]} { + #'chan blocked' docs state: 'Note that this only ever returns 1 when the channel has been configured to be non-blocking..' + #REVIEW - + #todo - figure out why we're here. + #can we even put a spinner so we don't keep emitting lines? We probably can't use any ansi functions that need to get a response on stdin..(like get_cursor_pos) + #punk::console::get_size is problematic if -winsize not available on the stdout channel - which is the case for certain 8.6 versions at least.. platform variances? + ## can't do this: set screeninfo [punk::console::get_size]; lassign $screeninfo _c cols _r rows + set outconf [chan configure stdout] + set RED [punk::ansi::a+ red bold]; set RST [punk::ansi::a] if {"windows" eq $::tcl_platform(platform)} { - set tputcmd [auto_execok tput] - if {$tputcmd ne ""} { - if {![catch {exec {*}$tputcmd cols lines} values]} { - lassign $values cols rows - } - } + set msg "${RED}$inputchan chan blocked is true. (line-length Tcl windows channel bug?)$RST \{$allwaiting\}" + } else { + set msg "${RED}$inputchan chan blocked is true.$RST \{$allwaiting\}" } + set cols "" + set rows "" + if {[dict exists $outconf -winsize]} { + lassign [dict get $outconf -winsize] cols rows + } else { + #fallback1 query terminal + if {![catch {punk::console::get_size} sdict]} { + set cols [dict get $sdict columns] + set rows [dict get $sdict rows] + } + + if {![string is integer -strict $cols] || ![string is integer -strict $rows]} { + + #fallback2 - try external executable. Which is a bit ugly + #tput can't seem to get dimensions (on FreeBSD at least) when not run interactively - ie via exec. (always returns 80x24 no matter if run with <@stdin) + + #bizarrely - tput can work with exec on windows if it's installed e.g from msys2 + #but can be *slow* compared to unix e.g 400ms+ vs <2ms on FreeBSD ! + #stty -a is 400ms+ vs 500us+ on FreeBSD - if {![string is integer -strict $cols] || ![string is integer -strict $rows]} { - #same for all platforms? tested on windows, wsl, FreeBSD - #exec stty -a gives a result on the first line like: - #speed xxxx baud; rows rr; columns cc; - #review - more robust parsing - do we know it's first line? - set sttycmd [auto_execok stty] - if {$sttycmd ne ""} { - #the more parseable: stty -g doesn't give rows/columns - if {![catch {exec {*}$sttycmd -a} result]} { - lassign [split $result \n] firstline - set lineparts [split $firstline {;}] ;#we seem to get segments that look well behaved enough to be treated as tcl lists - review - regex? - set rowinfo [lsearch -index end -inline $lineparts rows] - if {[llength $rowinfo] == 2} { - set rows [lindex $rowinfo 0] + if {"windows" eq $::tcl_platform(platform)} { + set tputcmd [auto_execok tput] + if {$tputcmd ne ""} { + if {![catch {exec {*}$tputcmd cols lines} values]} { + lassign $values cols rows + } } - set colinfo [lsearch -index end -inline $lineparts columns] - if {[llength $colinfo] == 2} { - set cols [lindex $colinfo 0] + } + + if {![string is integer -strict $cols] || ![string is integer -strict $rows]} { + #same for all platforms? tested on windows, wsl, FreeBSD + #exec stty -a gives a result on the first line like: + #speed xxxx baud; rows rr; columns cc; + #review - more robust parsing - do we know it's first line? + set sttycmd [auto_execok stty] + if {$sttycmd ne ""} { + #the more parseable: stty -g doesn't give rows/columns + if {![catch {exec {*}$sttycmd -a} result]} { + lassign [split $result \n] firstline + set lineparts [split $firstline {;}] ;#we seem to get segments that look well behaved enough to be treated as tcl lists - review - regex? + set rowinfo [lsearch -index end -inline $lineparts rows] + if {[llength $rowinfo] == 2} { + set rows [lindex $rowinfo 0] + } + set colinfo [lsearch -index end -inline $lineparts columns] + if {[llength $colinfo] == 2} { + set cols [lindex $colinfo 0] + } + } } } } } - } - if {[string is integer -strict $cols] && [string is integer -strict $rows]} { - #got_dimensions - todo - try spinner? - #puts -nonewline stdout [punk::ansi::move $rows 4]$msg - #use cursorsave_ version which avoids get_cursor_pos_list call - set msglen [ansistring length $msg] - punk::console::cursorsave_move_emitblock_return $rows [expr {$cols - $msglen -1}] $msg ;#supports also vt52 - } else { - #no mechanism to get console dimensions - #we are reduced to continuously spewing lines. - puts stderr $msg - } + if {[string is integer -strict $cols] && [string is integer -strict $rows]} { + #got_dimensions - todo - try spinner? + #puts -nonewline stdout [punk::ansi::move $rows 4]$msg + #use cursorsave_ version which avoids get_cursor_pos_list call + set msglen [ansistring length $msg] + punk::console::cursorsave_move_emitblock_return $rows [expr {$cols - $msglen -1}] $msg ;#supports also vt52 + } else { + #no mechanism to get console dimensions + #we are reduced to continuously spewing lines. + puts stderr $msg + } - after 100 + after 100 + } + set input_chunks_waiting($inputchan) [list $allwaiting] } - set input_chunks_waiting($inputchan) [list $allwaiting] } - + # -- } else { - punk::repl::repl_handler_checkchannel $inputchan - punk::repl::repl_handler_checkcontrolsignal_linemode $inputchan - # -- --- --- - #set chunksize [gets $inputchan chunk] - # -- --- --- - set chunk [read $inputchan] - set chunksize [string length $chunk] - # -- --- --- - if {$chunksize > 0} { - #punk::console::cursorsave_move_emitblock_return 35 120 "chunk: [ansistring VIEW -lf 1 "...[string range $chunk end-10 end]"]" - set ln $chunk ;#temp - #punk::console::cursorsave_move_emitblock_return 25 30 [textblock::frame -title line "[a+ green]$waitingchunk[a][a+ red][ansistring VIEW -lf 1 $ln][a+ green]pending:[chan pending input stdin][a]"] - if {[string index $ln end] eq "\n"} { - lappend stdinlines [string range $ln 0 end-1] - punk::repl::repl_handler_restorechannel_if_not_eof $inputchan $original_input_conf - uplevel #0 [list repl::repl_process_data $inputchan line "" $stdinlines $prompt_config] - } else { - lappend input_chunks_waiting($inputchan) $ln + if {$readmore} { + punk::repl::repl_handler_checkchannel $inputchan + punk::repl::repl_handler_checkcontrolsignal_linemode $inputchan + # -- --- --- + #set chunksize [gets $inputchan chunk] + # -- --- --- + set chunk [read $inputchan] + set chunksize [string length $chunk] + # -- --- --- + if {$chunksize > 0} { + #punk::console::cursorsave_move_emitblock_return 35 120 "chunk: [ansistring VIEW -lf 1 "...[string range $chunk end-10 end]"]" + set ln $chunk ;#temp + #punk::console::cursorsave_move_emitblock_return 25 30 [textblock::frame -title line "[a+ green]$waitingchunk[a][a+ red][ansistring VIEW -lf 1 $ln][a+ green]pending:[chan pending input stdin][a]"] + if {[string index $ln end] eq "\n"} { + lappend stdinlines [string range $ln 0 end-1] + punk::repl::repl_handler_restorechannel_if_not_eof $inputchan $original_input_conf + uplevel #0 [list repl::repl_process_data $inputchan line "" $stdinlines $prompt_config] + } else { + lappend input_chunks_waiting($inputchan) $ln + } } } } @@ -1582,19 +1624,21 @@ proc repl::repl_handler {inputchan prompt_config} { } if {$continue} { - if {[dict get $original_input_conf -blocking] ne "0" || [dict get $original_input_conf -translation] ne "lf"} { - chan configure $inputchan -blocking 0 - chan configure $inputchan -translation lf - } - set chunk [read $inputchan] - #we expect a chan configured with -blocking 0 to be blocked immediately after reads - #test - just bug console for now - try to understand when/how/if a non blocking read occurs. - if {![chan blocked $inputchan]} { - puts stderr "repl_handler->$inputchan not blocked after read" - } + if {$readmore} { + if {[dict get $original_input_conf -blocking] ne "0" || [dict get $original_input_conf -translation] ne "lf"} { + chan configure $inputchan -blocking 0 + chan configure $inputchan -translation lf + } + set chunk [read $inputchan] + #we expect a chan configured with -blocking 0 to be blocked immediately after reads + #test - just bug console for now - try to understand when/how/if a non blocking read occurs. + if {![chan blocked $inputchan]} { + puts stderr "repl_handler->$inputchan not blocked after read" + } - punk::repl::repl_handler_restorechannel_if_not_eof $inputchan $original_input_conf - uplevel #0 [list repl::repl_process_data $inputchan raw-read $chunk [list] $prompt_config] + punk::repl::repl_handler_restorechannel_if_not_eof $inputchan $original_input_conf + uplevel #0 [list repl::repl_process_data $inputchan raw-read $chunk [list] $prompt_config] + } while {[llength $input_chunks_waiting($inputchan)]} { set chunkzero [lpop input_chunks_waiting($inputchan) 0] if {$chunkzero eq ""} {continue} ;#why empty waiting - and is there any point passing on? @@ -1604,33 +1648,35 @@ proc repl::repl_handler {inputchan prompt_config} { } } - if {![chan eof $inputchan]} { - ################################################################################## - #Re-enable channel read handler only if no waiting chunks - must process in order - ################################################################################## - if {![llength $input_chunks_waiting($inputchan)]} { - chan event $inputchan readable [list ::repl::repl_handler $inputchan $prompt_config] + if {$readmore} { + if {![chan eof $inputchan]} { + ################################################################################## + #Re-enable channel read handler only if no waiting chunks - must process in order + ################################################################################## + if {![llength $input_chunks_waiting($inputchan)]} { + chan event $inputchan readable [list ::repl::repl_handler $inputchan $readmore $prompt_config] + } else { + #review + #puts stderr "warning: after idle re-enable repl::repl_handler in thread: [thread::id]" + after idle [list ::repl::repl_handler $inputchan $readmore $prompt_config] + } + #################################################### } else { - #review - #puts stderr "warning: after idle re-enable repl::repl_handler in thread: [thread::id]" - after idle [list ::repl::repl_handler $inputchan $prompt_config] - } - #################################################### - } else { - #repl_handler_checkchannel $inputchan - chan event $inputchan readable {} - set reading 0 - #target is the 'main' interp in codethread. - #(note bug where thread::send goes to code interp, but thread::send -async goes to main interp) - # https://core.tcl-lang.org/thread/tktview/0de73f04c7ce188b13a4 - - thread::send -async $::repl::codethread {set ::punk::repl::codethread::is_running 0} ;#to main interp of codethread - if {$::tcl_interactive} { - rputs stderr "\nrepl_handler EOF inputchannel:[chan conf $inputchan]" - #rputs stderr "\n|repl> ctrl-c EOF on $inputchan." + #repl_handler_checkchannel $inputchan + chan event $inputchan readable {} + set reading 0 + #target is the 'main' interp in codethread. + #(note bug where thread::send goes to code interp, but thread::send -async goes to main interp) + # https://core.tcl-lang.org/thread/tktview/0de73f04c7ce188b13a4 + + thread::send -async $::repl::codethread {set ::punk::repl::codethread::is_running 0} ;#to main interp of codethread + if {$::tcl_interactive} { + rputs stderr "\nrepl_handler EOF inputchannel:[chan conf $inputchan]" + #rputs stderr "\n|repl> ctrl-c EOF on $inputchan." + } + set [namespace current]::done 1 + after 1 [list repl::reopen_stdin] } - set [namespace current]::done 1 - after 1 [list repl::reopen_stdin] } set in_repl_handler [list] } diff --git a/src/modules/punk/repo-999999.0a1.0.tm b/src/modules/punk/repo-999999.0a1.0.tm index 727b563d..060431fe 100644 --- a/src/modules/punk/repo-999999.0a1.0.tm +++ b/src/modules/punk/repo-999999.0a1.0.tm @@ -218,7 +218,7 @@ namespace eval punk::repo { if {$fossilcmd eq "commit"} { if {[llength [file split $fosroot]]} { if {[file exists [file join $fosroot src/buildsuites]]} { - puts stderr "Todo - check buildsites/suite/projects for current branch/tag and update download_and_build_config" + puts stderr "Todo - check buildsuites/suite/projects for current branch/tag and update download_and_build_config" } } } elseif {$fossilcmd in [list "info" "status"]} { diff --git a/src/modules/shellfilter-999999.0a1.0.tm b/src/modules/shellfilter-999999.0a1.0.tm index 5b8908c0..39c14a32 100644 --- a/src/modules/shellfilter-999999.0a1.0.tm +++ b/src/modules/shellfilter-999999.0a1.0.tm @@ -2472,7 +2472,14 @@ namespace eval shellfilter { set exitinfo [list error "$errMsg" errorCode $::errorCode errorInfo "$::errorInfo"] } } + #puts "shellfilter::run finished call" + #------------------------- + #warning - without flush stdout - we can get hang, but only on some terminals + # - mechanism for this problem not understood! + flush stdout + flush stderr + #------------------------- #the previous redirections on the underlying inchan/outchan/errchan items will be restored from the -aside setting during removal #Remove execution-time Tees from stack @@ -2480,6 +2487,7 @@ namespace eval shellfilter { shellfilter::stack::remove stderr $id_err #shellfilter::stack::remove stderr $id_in + #puts stderr "shellfilter::run complete..." #chan configure stderr -buffering line #flush stdout diff --git a/src/modules/shellrun-0.1.1.tm b/src/modules/shellrun-0.1.1.tm index 478c70fa..c3f7ab10 100644 --- a/src/modules/shellrun-0.1.1.tm +++ b/src/modules/shellrun-0.1.1.tm @@ -187,10 +187,10 @@ namespace eval shellrun { #--------------------------------------------------------------------------------------------- set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none ] #--------------------------------------------------------------------------------------------- - foreach id $idlist_stderr { shellfilter::stack::remove stderr $id } + #puts stderr "shellrun::run exitinfo: $exitinfo" flush stderr flush stdout diff --git a/src/modules/test/AGENTS.md b/src/modules/test/AGENTS.md new file mode 100644 index 00000000..218c4d30 --- /dev/null +++ b/src/modules/test/AGENTS.md @@ -0,0 +1,14 @@ +# test module information +--- +subfolders (that don't begin with a # or _ character) within this test folder form part of the Tcl namespace of the resulting modules that are produced from running ' src/make.tcl modules' + +The #modpod- folder for a module contain files that will stored in the final module's .tm file (zip based) which is built by make.tcl into the /modules/test folder (again with further subfolders depending on whether the module is namespaced) + +The final version of the built modules are determined from corresponding -buildversion.txt files placed at the same level as the corresponding #modpod--999999.0a1.0 folder + +example: A final installed module /modules/test/foo/baz/foobazzer-1.1.tm corresponds to the tcl module test::foo::baz::foobazzer and will have its source tests and associated files in the folder /src/modules/test/foo/baz/#modpod-foobazzer-999999.0a1.0 with a corresponding version number file at /src/modules/test/foo/baz/foobazzer-buildversion.txt + +A new testmodule for a package can be generated from the template template_test built into the punk::mix::templates package which is referenced as 'punk.test' when creating a new module using the 'dev module.new' command. This command is an alias for punk::mix::commandset::module::new. + + + diff --git a/src/modules/test/punk/#modpod-ansi-999999.0a1.0/ansi-999999.0a1.0.tm b/src/modules/test/punk/#modpod-ansi-999999.0a1.0/ansi-999999.0a1.0.tm index 4f88c2ba..e497f903 100644 --- a/src/modules/test/punk/#modpod-ansi-999999.0a1.0/ansi-999999.0a1.0.tm +++ b/src/modules/test/punk/#modpod-ansi-999999.0a1.0/ansi-999999.0a1.0.tm @@ -13,112 +13,26 @@ # Meta license MIT # @@ Meta End - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin shellspy_module_test::punk::ansi 0 999999.0a1.0] -#[copyright "2025"] -#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] -#[require test::punk::ansi] -#[keywords module] -#[description] -#[para] - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of test::punk::ansi -#[subsection Concepts] -#[para] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by test::punk::ansi -#[list_begin itemized] - package require Tcl 8.6- -#*** !doctools -#[item] [package {Tcl 8.6}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - tcl::namespace::eval test::punk::ansi { - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - # Base namespace - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - #*** !doctools - #[subsection {Namespace test::punk::ansi}] - #[para] Core API functions for test::punk::ansi - #[list_begin definitions] - variable PUNKARGS - variable pkg test::punk::ansi variable version set version 999999.0a1.0 - - package require packageTest - packageTest::makeAPI test::punk::ansi $version punk::ansi; #will package provide test::punk::args $version + package require packagetest + packagetest::makeAPI test::punk::ansi $version punk::ansi; #will package provide test::punk::args $version package forget punk::ansi package require punk::ansi - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace test::punk::ansi ---}] } -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval test::punk::ansi::lib { - tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase - tcl::namespace::path [tcl::namespace::parent] - #*** !doctools - #[subsection {Namespace test::punk::ansi::lib}] - #[para] Secondary functions that are part of the API - #[list_begin definitions] - #proc utility1 {p1 args} { - # #*** !doctools - # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] - # #[para]Description of utility1 - # return 1 - #} - - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace test::punk::ansi::lib ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - - - -# == === === === === === === === === === === === === === === +# == === === === === === === === === === === === === === === # Sample 'about' function with punk::args documentation -# == === === === === === === === === === === === === === === +# == === === === === === === === === === === === === === === tcl::namespace::eval test::punk::ansi { tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase variable PUNKARGS @@ -141,7 +55,7 @@ tcl::namespace::eval test::punk::ansi { set about_topics [list] foreach f $topic_funs { set tail [namespace tail $f] - lappend about_topics [string range $tail [string length get_topic_] end] + lappend about_topics [string range $tail [string length get_topic_] end] } #Adjust this function or 'default_topics' if a different order is required return [lsort $about_topics] @@ -149,10 +63,10 @@ tcl::namespace::eval test::punk::ansi { proc default_topics {} {return [list Description *]} # ------------------------------------------------------------- - # get_topic_ functions add more to auto-include in about topics + # get_topic_ functions add more to auto-include in about topics # ------------------------------------------------------------- proc get_topic_Description {} { - punk::args::lib::tstr [string trim { + punk::args::lib::tstr [string trim { package test::punk::ansi } \n] } @@ -179,9 +93,9 @@ tcl::namespace::eval test::punk::ansi { # we re-use the argument definition from punk::args::standard_about and override some items set overrides [dict create] dict set overrides @id -id "::test::punk::ansi::about" - dict set overrides @cmd -name "test::punk::ansi::about" + dict set overrides @cmd -name "test::punk::ansi::about" dict set overrides @cmd -help [string trim [punk::args::lib::tstr { - About test::punk::ansi + About test::punk::ansi }] \n] dict set overrides topic -choices [list {*}[test::punk::ansi::argdoc::about_topics] *] dict set overrides topic -choicerestricted 1 @@ -211,15 +125,11 @@ namespace eval ::punk::args::register { } # ----------------------------------------------------------------------------- -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready package provide test::punk::ansi [tcl::namespace::eval test::punk::ansi { variable pkg test::punk::ansi variable version set version 999999.0a1.0 }] +## Ready return -#*** !doctools -#[manpage_end] - diff --git a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/tests/define.test#..+args+define.test.fauxlink b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/tests/define.test#..+args+define.test.fauxlink new file mode 100644 index 00000000..e69de29b diff --git a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/tests/opts.test#..+args+opts.test.fauxlink b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/tests/opts.test#..+args+opts.test.fauxlink new file mode 100644 index 00000000..e69de29b diff --git a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-999999.0a1.0.tm b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-999999.0a1.0.tm index 4afc180c..eae028f7 100644 --- a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-999999.0a1.0.tm +++ b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-999999.0a1.0.tm @@ -13,99 +13,21 @@ # Meta license MIT # @@ Meta End - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin shellspy_module_test::punk::args 0 999999.0a1.0] -#[copyright "2025"] -#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] -#[require test::punk::args] -#[keywords module] -#[description] -#[para] - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of test::punk::args -#[subsection Concepts] -#[para] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by test::punk::args -#[list_begin itemized] - package require Tcl 8.6- -#*** !doctools -#[item] [package {Tcl 8.6}] - - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - - - tcl::namespace::eval test::punk::args { - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - # Base namespace - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - #*** !doctools - #[subsection {Namespace test::punk::args}] - #[para] Core API functions for test::punk::args - #[list_begin definitions] - variable PUNKARGS variable pkg test::punk::args variable version set version 999999.0a1.0 - package require packageTest - packageTest::makeAPI test::punk::args $version punk::args; #will package provide test::punk::args $version + package require packagetest + packagetest::makeAPI test::punk::args $version punk::args; #will package provide test::punk::args $version package forget punk::args package require punk::args - - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace test::punk::args ---}] } -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -#tcl::namespace::eval test::punk::args::system { - #*** !doctools - #[subsection {Namespace test::punk::args::system}] - #[para] Internal functions that are not part of the API - - - -#} # == === === === === === === === === === === === === === === @@ -119,7 +41,7 @@ tcl::namespace::eval test::punk::args { lappend PUNKARGS [list { @id -id "(package)test::punk::args" @package -name "test::punk::args" -help\ - "Test suites for punk::args" + "Test suites for punk::args module" }] namespace eval argdoc { @@ -220,6 +142,3 @@ package provide test::punk::args [tcl::namespace::eval test::punk::args { }] return -#*** !doctools -#[manpage_end] - diff --git a/src/modules/test/punk/#modpod-lib-999999.0a1.0/lib-999999.0a1.0.tm b/src/modules/test/punk/#modpod-lib-999999.0a1.0/lib-999999.0a1.0.tm index 08386ebf..21cb06c7 100644 --- a/src/modules/test/punk/#modpod-lib-999999.0a1.0/lib-999999.0a1.0.tm +++ b/src/modules/test/punk/#modpod-lib-999999.0a1.0/lib-999999.0a1.0.tm @@ -13,86 +13,19 @@ # Meta license MIT # @@ Meta End - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin shellspy_module_test::punk::lib 0 999999.0a1.0] -#[copyright "2025"] -#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] -#[require test::punk::lib] -#[keywords module] -#[description] -#[para] - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of test::punk::lib -#[subsection Concepts] -#[para] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by test::punk::lib -#[list_begin itemized] - package require Tcl 8.6- -#*** !doctools -#[item] [package {Tcl 8.6}] - - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - - - tcl::namespace::eval test::punk::lib { - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - # Base namespace - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - #*** !doctools - #[subsection {Namespace test::punk::lib}] - #[para] Core API functions for test::punk::lib - #[list_begin definitions] - variable PUNKARGS - variable pkg test::punk::lib variable version set version 999999.0a1.0 - package require packageTest - packageTest::makeAPI test::punk::lib $version punk::lib; #will package provide test::punk::lib $version - + package require packagetest + packagetest::makeAPI test::punk::lib $version punk::lib; #will package provide test::punk::lib $version package forget punk::lib package require punk::lib - - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace test::punk::lib ---}] } -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # == === === === === === === === === === === === === === === @@ -106,7 +39,7 @@ tcl::namespace::eval test::punk::lib { lappend PUNKARGS [list { @id -id "(package)test::punk::lib" @package -name "test::punk::lib" -help\ - "Test suites for punk::lib" + "Test suites for punk::lib module" }] namespace eval argdoc { @@ -184,8 +117,7 @@ tcl::namespace::eval test::punk::lib { } } # end of sample 'about' function -# == === === === === === === === === === === === === === === - +# == === === === === === === === === === === === === === === # ----------------------------------------------------------------------------- # register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked @@ -198,14 +130,10 @@ namespace eval ::punk::args::register { } # ----------------------------------------------------------------------------- -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready package provide test::punk::lib [tcl::namespace::eval test::punk::lib { variable pkg test::punk::lib variable version set version 999999.0a1.0 }] +## Ready return - -#*** !doctools -#[manpage_end] diff --git a/src/modules/test/punk/#modpod-ns-999999.0a1.0/ns-999999.0a1.0.tm b/src/modules/test/punk/#modpod-ns-999999.0a1.0/ns-999999.0a1.0.tm index feca648e..2308bfa0 100644 --- a/src/modules/test/punk/#modpod-ns-999999.0a1.0/ns-999999.0a1.0.tm +++ b/src/modules/test/punk/#modpod-ns-999999.0a1.0/ns-999999.0a1.0.tm @@ -28,8 +28,8 @@ tcl::namespace::eval test::punk::ns { variable version set version 999999.0a1.0 - package require packageTest - packageTest::makeAPI test::punk::ns $version punk::ns; #will package provide test::punk::ns $version + package require packagetest + packagetest::makeAPI test::punk::ns $version punk::ns; #will package provide test::punk::ns $version package forget punk::ns package require punk::ns diff --git a/src/modules/test/runtestmodules.tcl b/src/modules/test/runtestmodules.tcl new file mode 100644 index 00000000..b7846da6 --- /dev/null +++ b/src/modules/test/runtestmodules.tcl @@ -0,0 +1,166 @@ +#!punk902testrunner shellspy +#This script uses shellfilter::run calls under the hood - which probably requires a built punkshell binary to function properly. +#(plain tclsh may stall - todo - review reasons for this and whether shellfilter can be modified to support ordinary tclsh) +#A known working copy of a punk shell executable should be placed on the path and the shebang line updated to reflect this + + +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 list -default "" -help\ + "arguments that will be left in ::argv for tcltest + to handle" + @values -min 0 -max -1 + glob -type string -multiple 1 -optional 1 -help\ + " names or glob patterns of test modules to run. + Note that this script will search for all modules + within the test namespace that are known to the + current interpreter - not just those within the + current project." +} +set argd [punk::args::parse $::argv withid (script)::runtestmodules] +lassign [dict values $argd] leaders opts values received +set tcltestoptions [dict get $opts -tcltestoptions] +if {![dict exists $received glob]} { + set pkg_globs [list *] +} else { + set pkg_globs [dict get $values glob] +} + +set ::argv $tcltestoptions +set ::argc [llength $tcltestoptions] + + +#bogus require to ensure modules within path test have been scanned to be in Tcl's 'package ifneeded' in-memory database +catch {package require test::bogus666} +set tmlist [tcl::tm::list] +foreach tmfolder $tmlist { + set tfolder [file join $tmfolder test] + if {[file exists $tfolder]} { + puts stdout "checking tm test folder $tfolder" + set subfolders [glob -nocomplain -dir $tfolder -type d -tail *] + foreach sub $subfolders { + if {[string match #* $sub]} { + continue + } + puts stdout "bogus require of test::${sub}::bogus666" + catch {package require test::${sub}::bogus666} + } + } +} +set alltestpkgs [lsearch -all -inline [package names] test::*] +if {![llength $alltestpkgs]} { + puts stder "No packages matching test::* found" + exit 1 +} +if {[llength $pkg_globs] == 1 && [lindex $pkg_globs 0] eq "*"} { + set matchedtestpkgs $alltestpkgs +} else { + set matchedtestpkgs [list] + foreach pkg $alltestpkgs { + foreach g $pkg_globs { + if {[string match $g $pkg]} { + lappend matchedtestpkgs $pkg + break + } + } + } +} +if {![llength $matchedtestpkgs]} { + puts stderr "No test packages matched supplied glob patterns" + exit 1 +} +puts "matchedtestpkgs: $matchedtestpkgs" +set punktestpkgs [list] +foreach pkg $matchedtestpkgs { + if {![catch {package require $pkg}]} { + if {[info commands ::${pkg}::RUN] ne ""} { + lappend punktestpkgs $pkg + } + } else { + puts stderr "failed to load test package $pkg" + } +} +if {![llength $punktestpkgs]} { + puts stderr "No test packages with RUN command were able to be loaded" + exit 1 +} +set scriptname [file tail [info script]] +set results [dict create] +dict set results total 0 +dict set results passed 0 +dict set results skipped 0 +dict set results failed 0 +set pkgs_with_fails [list] +set pkgs_without_fails [list] +package require shellrun +puts "running tests in [llength $punktestpkgs] packages $punktestpkgs" +flush stderr +flush stdout +package require punk::ansi +foreach pkg $punktestpkgs { + puts stdout "running test pkg $pkg" + if {[catch { + #set result [shellrun::runout -tcl ${pkg}::RUN] + set result [shellrun::runx -tcl ${pkg}::RUN] + #set result [shellrun::runx ls] + } errM]} { + puts stderr "error calling 'runout -tcl ${pkg}::RUN' $errM"; flush stderr + set result {none ""} + } + puts stdout "executed ${pkg}::RUN" + flush stdout + set i 0 + dict for {what chunk} $result { + set chunk [string map [list \r\n \n] $chunk] + switch -- $what { + stdout { + foreach ln [split $chunk \n] { + incr i + if {[string match "Tests ended at*" $ln]} { + puts stdout " [punk::ansi::ansistring VIEW -lf 2 -cr 1 "$pkg $ln"]" + } elseif {[string match "*:*Total*Passed*Skipped*Failed*" $ln]} { + set fields [lrange $ln 1 end] + dict for {K v} $fields { + set k [string tolower $K] + dict incr results $k $v + if {$k eq "failed"} { + if {$v == 0} { + lappend pkgs_without_fails $pkg + } elseif {$v > 0} { + lappend pkgs_with_fails $pkg + } + } + } + puts stdout "$pkg $ln" + } else { + puts stdout " $ln" + #puts stdout "$i" + } + } + flush stdout + } + stderr { + puts stderr " [punk::ansi::ansistring VIEW -lf 2 -cr 1 $chunk]" + flush stderr + } + default { + puts stderr "<${what}> $chunk" + flush stderr + } + } + } + puts stdout "completed pkg test ${pkg}" +} +puts stdout "packages without failures: $pkgs_without_fails" +puts stdout "packages with failures: $pkgs_with_fails" +puts stdout "results: Total [dict get $results total] Passed [dict get $results passed] Skipped [dict get $results skipped] Failed [dict get $results failed]" +#after 5000 {set ::done true} +#vwait ::done +puts stdout "DONE" +#exit 0 + diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config index 0ea2f344..8ea31ad3 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config @@ -19,6 +19,7 @@ set bootsupport_modules [list\ src/vendormodules metaface\ src/vendormodules modpod\ src/vendormodules overtype\ + src/vendormodules packagetest\ src/vendormodules pattern\ src/vendormodules patterncmd\ src/vendormodules patternlib\ diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/packagetest-0.1.7.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/packagetest-0.1.7.tm new file mode 100644 index 00000000..658d45a4 Binary files /dev/null and b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/packagetest-0.1.7.tm differ diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patterncipher-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patterncipher-0.1.1.tm index 62b03cbc..0aa12476 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patterncipher-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patterncipher-0.1.1.tm @@ -37,7 +37,6 @@ package provide patterncipher [namespace eval patterncipher { package require ascii85 ;#tcllib package require pattern -::pattern::init ;# initialises (if not already) namespace eval ::patterncipher { namespace eval algo::txt { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.5.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.5.tm index db369f06..5138ac6d 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.5.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.5.tm @@ -2370,6 +2370,54 @@ namespace eval punk::lib { append body [info body is_list_all_ni_list2] proc is_list_all_ni_list2 {a b} $body } + proc is_cachedlist_all_ni_list {a b} { + upvar 0 ::punk::lib::caches::funcs_ni_list funcs + if {[info exists funcs($a)]} { + return [[set funcs($a)] $b] + } + set keybytes [encoding convertto utf-8 $a] + set key [binary encode base64 $keybytes] ;#one single-line base64 string + + set expression "" + foreach t $a { + #append expression "({$t} ni \$b) && " + append expression "{$t} ni \$b && " + } + set expression [string trimright $expression " &"] ;#trim trailing spaces and ampersands + proc ::punk::lib::caches::ni_list_$key {b} [string map [list @expression@ $expression] { + return [expr {@expression@}] + }] + + set funcs($a) ::punk::lib::caches::ni_list_$key + return [punk::lib::caches::ni_list_$key $b] + } + proc is_cachedlist_all_ni_list2 {a b} { + upvar 0 ::punk::lib::caches::funcs_ni_list funcs + if {[info exists funcs($a)]} { + return [[set funcs($a)] $b] + } + set keybytes [encoding convertto utf-8 $a] + set key [binary encode base64 $keybytes] ;#one single-line base64 string + + set d [dict create] + foreach x $a { + dict set d $x "" + } + #constructing a switch statement could be an option + # - but would need to avoid using escapes in order to get a jump-table + # - this would need runtime mapping of values - unlikely to be a win + proc ::punk::lib::caches::ni_list_$key {b} [string map [list @d@ $d] { + foreach x $b { + if {[::tcl::dict::exists {@d@} $x]} { + return 0 + } + } + return 1 + }] + + set funcs($a) ::punk::lib::caches::ni_list_$key + return [punk::lib::caches::ni_list_$key $b] + } namespace eval argdoc { variable PUNKARGS @@ -5389,6 +5437,10 @@ tcl::namespace::eval punk::lib::system { #[list_end] [comment {--- end definitions namespace punk::lib::system ---}] } +tcl::namespace::eval punk::lib::caches { + +} + tcl::namespace::eval punk::lib::debug { proc showdict {args} {} } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm index bcf2221f..59f23842 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm @@ -170,7 +170,16 @@ namespace eval punk::mix::commandset::module { @values -min 1 -max 1 module -type string -help\ "Name of module, possibly including a namespace and/or version number - e.g mynamespace::mymodule-1.0" + e.g mynamespace::mymodule-1.0 + + Some templates may require a prefixing namespace in order to function + correctly. e.g punk.test module names should be of the form + test::mymodule or test::mymodule::mycomponent + where the modules under test are mymodule and mymodule::mycomponent. + For example with test module test::a::b::c + The 'pkg' and 'pkgunprefixed' placeholders (surrounded by % char) are + filled with test::a::b::c and a::b::c respectively. + " }] proc new {args} { set year [clock format [clock seconds] -format %Y] @@ -222,6 +231,9 @@ namespace eval punk::mix::commandset::module { } else { set modulename $module } + #normalize modulename to remove any leading :: in case it was supplied that way + set modulename [string trimleft $modulename :] + punk::mix::cli::lib::validate_modulename $modulename -errorprefix "punk::mix::commandset::module::new" if {[regexp {[A-Z]} $module]} { @@ -410,7 +422,11 @@ namespace eval punk::mix::commandset::module { #for now the user has the option to override any templates and remove %moduletemplate% if it is a security/privacy concern #Don't put literal %x% in the code for the commandset::module itself - to stop them being seen by layout scanner as replacable tokens - set tagnames [list moduletemplate $moduletemplate project $projectname pkg $modulename year $year license $opt_license authors $opt_authors version $infile_version] + #JJJ + set pkg_parts [punk::ns::nsparts $modulename] ;#(modulename known not to have leading :: at this point) + set pkg_unprefixed [join [lrange $pkg_parts 1 end] ::] + #pkg_unprefixed may be empty - irrelevant for most templates but not ok for punk.test template - but where to reject? review + set tagnames [list moduletemplate $moduletemplate project $projectname pkg $modulename pkgunprefixed $pkg_unprefixed year $year license $opt_license authors $opt_authors version $infile_version] set strmap [list] foreach {tag val} $tagnames { lappend strmap %$tag% $val diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm index 0272500d..486720e8 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm @@ -479,7 +479,13 @@ proc repl::start {inchan args} { puts stderr "-->repl::start active on $inchan $args replthread:[thread::id] codethread:$codethread" set prompt_config [punk::repl::get_prompt_config] doprompt "P% " - chan event $inchan readable [list [namespace current]::repl_handler $inchan $prompt_config] + if {[llength $input_chunks_waiting($inchan)]} { + set readmore 0 + uplevel #0 [list [namespace current]::repl_handler $inchan $readmore $prompt_config] + #after 0 [list [namespace current]::repl_handler $inchan $readmore $prompt_config] + } + set readmore 1 + chan event $inchan readable [list [namespace current]::repl_handler $inchan $readmore $prompt_config] set reading 1 #catch { @@ -530,6 +536,22 @@ proc repl::start {inchan args} { #puts stderr "__> returning 0" return 0 } + +#put a script into the waiting buffer for evaluation +proc repl::submit {inputchan script} { + set prompt_config [punk::repl::get_prompt_config] + upvar ::punk::console::input_chunks_waiting input_chunks_waiting + if {[info exists input_chunks_waiting($inputchan)] && [llength $input_chunks_waiting($inputchan)]} { + set last [lindex $input_chunks_waiting($inputchan) end] + append last $script + lset input_chunks_waiting($inputchan) end $last + } else { + set input_chunks_waiting($inputchan) [list $script] + } + + #set readmore 0 + #after idle [list after 0 [list ::repl::repl_handler $inputchan $readmore $prompt_config]] +} proc repl::post_operations {} { if {[info exists ::repl::post_script] && [string length $::repl::post_script]} { #put aside post_script so the script has the option to add another post_script and restart the repl @@ -1384,7 +1406,10 @@ proc punk::repl::repl_handler_restorechannel_if_not_eof {inputchan previous_inpu } return [chan conf $inputchan] } -proc repl::repl_handler {inputchan prompt_config} { +proc repl::repl_handler {inputchan readmore prompt_config} { + #readmore set to zero used to process input_chunks_waiting without reading inputchan, + # and without rescheduling reader + # -- review variable in_repl_handler set in_repl_handler [list $inputchan $prompt_config] @@ -1451,115 +1476,132 @@ proc repl::repl_handler {inputchan prompt_config} { set waitingchunk [lindex $waitinglines end] # -- #set chunksize [gets $inputchan chunk] - set chunk [read $inputchan] - set chunksize [string length $chunk] - # -- - if {$chunksize > 0} { - if {[string index $chunk end] eq "\n"} { - lappend stdinlines $waitingchunk[string range $chunk 0 end-1] - #punk::console::cursorsave_move_emitblock_return 30 30 "repl_handler num_stdinlines [llength $stdinlines] chunk:$yellow[ansistring VIEW -lf 1 $chunk][a] fblocked:[fblocked $inputchan] pending:[chan pending input stdin]" - - punk::repl::repl_handler_restorechannel_if_not_eof $inputchan $original_input_conf - uplevel #0 [list repl::repl_process_data $inputchan line "" $stdinlines $prompt_config] - } else { - set input_chunks_waiting($inputchan) [list $allwaiting] - lappend input_chunks_waiting($inputchan) $chunk - } + if {!$readmore} { + set chunk "" + set chunksize 0 + uplevel #0 [list repl::repl_process_data $inputchan line "" $stdinlines $prompt_config] + set input_chunks_waiting($inputchan) [list $waitingchunk] } else { - #'chan blocked' docs state: 'Note that this only ever returns 1 when the channel has been configured to be non-blocking..' - if {[chan blocked $inputchan]} { - #REVIEW - - #todo - figure out why we're here. - #can we even put a spinner so we don't keep emitting lines? We probably can't use any ansi functions that need to get a response on stdin..(like get_cursor_pos) - #punk::console::get_size is problematic if -winsize not available on the stdout channel - which is the case for certain 8.6 versions at least.. platform variances? - ## can't do this: set screeninfo [punk::console::get_size]; lassign $screeninfo _c cols _r rows - set outconf [chan configure stdout] - set RED [punk::ansi::a+ red bold]; set RST [punk::ansi::a] - if {"windows" eq $::tcl_platform(platform)} { - set msg "${RED}$inputchan chan blocked is true. (line-length Tcl windows channel bug?)$RST \{$allwaiting\}" + set chunk [read $inputchan] + set chunksize [string length $chunk] + if {$chunksize > 0} { + if {[string index $chunk end] eq "\n"} { + lappend stdinlines $waitingchunk[string range $chunk 0 end-1] + #punk::console::cursorsave_move_emitblock_return 30 30 "repl_handler num_stdinlines [llength $stdinlines] chunk:$yellow[ansistring VIEW -lf 1 $chunk][a] fblocked:[fblocked $inputchan] pending:[chan pending input stdin]" + + punk::repl::repl_handler_restorechannel_if_not_eof $inputchan $original_input_conf + uplevel #0 [list repl::repl_process_data $inputchan line "" $stdinlines $prompt_config] } else { - set msg "${RED}$inputchan chan blocked is true.$RST \{$allwaiting\}" + set input_chunks_waiting($inputchan) [list $allwaiting] + lappend input_chunks_waiting($inputchan) $chunk } - set cols "" - set rows "" - if {[dict exists $outconf -winsize]} { - lassign [dict get $outconf -winsize] cols rows - } else { - #fallback - try external executable. Which is a bit ugly - #tput can't seem to get dimensions (on FreeBSD at least) when not run interactively - ie via exec. (always returns 80x24 no matter if run with <@stdin) - - #bizarrely - tput can work with exec on windows if it's installed e.g from msys2 - #but can be *slow* compared to unix e.g 400ms+ vs <2ms on FreeBSD ! - #stty -a is 400ms+ vs 500us+ on FreeBSD - + } else { + if {[chan blocked $inputchan]} { + #'chan blocked' docs state: 'Note that this only ever returns 1 when the channel has been configured to be non-blocking..' + #REVIEW - + #todo - figure out why we're here. + #can we even put a spinner so we don't keep emitting lines? We probably can't use any ansi functions that need to get a response on stdin..(like get_cursor_pos) + #punk::console::get_size is problematic if -winsize not available on the stdout channel - which is the case for certain 8.6 versions at least.. platform variances? + ## can't do this: set screeninfo [punk::console::get_size]; lassign $screeninfo _c cols _r rows + set outconf [chan configure stdout] + set RED [punk::ansi::a+ red bold]; set RST [punk::ansi::a] if {"windows" eq $::tcl_platform(platform)} { - set tputcmd [auto_execok tput] - if {$tputcmd ne ""} { - if {![catch {exec {*}$tputcmd cols lines} values]} { - lassign $values cols rows - } - } + set msg "${RED}$inputchan chan blocked is true. (line-length Tcl windows channel bug?)$RST \{$allwaiting\}" + } else { + set msg "${RED}$inputchan chan blocked is true.$RST \{$allwaiting\}" } + set cols "" + set rows "" + if {[dict exists $outconf -winsize]} { + lassign [dict get $outconf -winsize] cols rows + } else { + #fallback1 query terminal + if {![catch {punk::console::get_size} sdict]} { + set cols [dict get $sdict columns] + set rows [dict get $sdict rows] + } + + if {![string is integer -strict $cols] || ![string is integer -strict $rows]} { + + #fallback2 - try external executable. Which is a bit ugly + #tput can't seem to get dimensions (on FreeBSD at least) when not run interactively - ie via exec. (always returns 80x24 no matter if run with <@stdin) + + #bizarrely - tput can work with exec on windows if it's installed e.g from msys2 + #but can be *slow* compared to unix e.g 400ms+ vs <2ms on FreeBSD ! + #stty -a is 400ms+ vs 500us+ on FreeBSD - if {![string is integer -strict $cols] || ![string is integer -strict $rows]} { - #same for all platforms? tested on windows, wsl, FreeBSD - #exec stty -a gives a result on the first line like: - #speed xxxx baud; rows rr; columns cc; - #review - more robust parsing - do we know it's first line? - set sttycmd [auto_execok stty] - if {$sttycmd ne ""} { - #the more parseable: stty -g doesn't give rows/columns - if {![catch {exec {*}$sttycmd -a} result]} { - lassign [split $result \n] firstline - set lineparts [split $firstline {;}] ;#we seem to get segments that look well behaved enough to be treated as tcl lists - review - regex? - set rowinfo [lsearch -index end -inline $lineparts rows] - if {[llength $rowinfo] == 2} { - set rows [lindex $rowinfo 0] + if {"windows" eq $::tcl_platform(platform)} { + set tputcmd [auto_execok tput] + if {$tputcmd ne ""} { + if {![catch {exec {*}$tputcmd cols lines} values]} { + lassign $values cols rows + } } - set colinfo [lsearch -index end -inline $lineparts columns] - if {[llength $colinfo] == 2} { - set cols [lindex $colinfo 0] + } + + if {![string is integer -strict $cols] || ![string is integer -strict $rows]} { + #same for all platforms? tested on windows, wsl, FreeBSD + #exec stty -a gives a result on the first line like: + #speed xxxx baud; rows rr; columns cc; + #review - more robust parsing - do we know it's first line? + set sttycmd [auto_execok stty] + if {$sttycmd ne ""} { + #the more parseable: stty -g doesn't give rows/columns + if {![catch {exec {*}$sttycmd -a} result]} { + lassign [split $result \n] firstline + set lineparts [split $firstline {;}] ;#we seem to get segments that look well behaved enough to be treated as tcl lists - review - regex? + set rowinfo [lsearch -index end -inline $lineparts rows] + if {[llength $rowinfo] == 2} { + set rows [lindex $rowinfo 0] + } + set colinfo [lsearch -index end -inline $lineparts columns] + if {[llength $colinfo] == 2} { + set cols [lindex $colinfo 0] + } + } } } } } - } - if {[string is integer -strict $cols] && [string is integer -strict $rows]} { - #got_dimensions - todo - try spinner? - #puts -nonewline stdout [punk::ansi::move $rows 4]$msg - #use cursorsave_ version which avoids get_cursor_pos_list call - set msglen [ansistring length $msg] - punk::console::cursorsave_move_emitblock_return $rows [expr {$cols - $msglen -1}] $msg ;#supports also vt52 - } else { - #no mechanism to get console dimensions - #we are reduced to continuously spewing lines. - puts stderr $msg - } + if {[string is integer -strict $cols] && [string is integer -strict $rows]} { + #got_dimensions - todo - try spinner? + #puts -nonewline stdout [punk::ansi::move $rows 4]$msg + #use cursorsave_ version which avoids get_cursor_pos_list call + set msglen [ansistring length $msg] + punk::console::cursorsave_move_emitblock_return $rows [expr {$cols - $msglen -1}] $msg ;#supports also vt52 + } else { + #no mechanism to get console dimensions + #we are reduced to continuously spewing lines. + puts stderr $msg + } - after 100 + after 100 + } + set input_chunks_waiting($inputchan) [list $allwaiting] } - set input_chunks_waiting($inputchan) [list $allwaiting] } - + # -- } else { - punk::repl::repl_handler_checkchannel $inputchan - punk::repl::repl_handler_checkcontrolsignal_linemode $inputchan - # -- --- --- - #set chunksize [gets $inputchan chunk] - # -- --- --- - set chunk [read $inputchan] - set chunksize [string length $chunk] - # -- --- --- - if {$chunksize > 0} { - #punk::console::cursorsave_move_emitblock_return 35 120 "chunk: [ansistring VIEW -lf 1 "...[string range $chunk end-10 end]"]" - set ln $chunk ;#temp - #punk::console::cursorsave_move_emitblock_return 25 30 [textblock::frame -title line "[a+ green]$waitingchunk[a][a+ red][ansistring VIEW -lf 1 $ln][a+ green]pending:[chan pending input stdin][a]"] - if {[string index $ln end] eq "\n"} { - lappend stdinlines [string range $ln 0 end-1] - punk::repl::repl_handler_restorechannel_if_not_eof $inputchan $original_input_conf - uplevel #0 [list repl::repl_process_data $inputchan line "" $stdinlines $prompt_config] - } else { - lappend input_chunks_waiting($inputchan) $ln + if {$readmore} { + punk::repl::repl_handler_checkchannel $inputchan + punk::repl::repl_handler_checkcontrolsignal_linemode $inputchan + # -- --- --- + #set chunksize [gets $inputchan chunk] + # -- --- --- + set chunk [read $inputchan] + set chunksize [string length $chunk] + # -- --- --- + if {$chunksize > 0} { + #punk::console::cursorsave_move_emitblock_return 35 120 "chunk: [ansistring VIEW -lf 1 "...[string range $chunk end-10 end]"]" + set ln $chunk ;#temp + #punk::console::cursorsave_move_emitblock_return 25 30 [textblock::frame -title line "[a+ green]$waitingchunk[a][a+ red][ansistring VIEW -lf 1 $ln][a+ green]pending:[chan pending input stdin][a]"] + if {[string index $ln end] eq "\n"} { + lappend stdinlines [string range $ln 0 end-1] + punk::repl::repl_handler_restorechannel_if_not_eof $inputchan $original_input_conf + uplevel #0 [list repl::repl_process_data $inputchan line "" $stdinlines $prompt_config] + } else { + lappend input_chunks_waiting($inputchan) $ln + } } } } @@ -1582,19 +1624,21 @@ proc repl::repl_handler {inputchan prompt_config} { } if {$continue} { - if {[dict get $original_input_conf -blocking] ne "0" || [dict get $original_input_conf -translation] ne "lf"} { - chan configure $inputchan -blocking 0 - chan configure $inputchan -translation lf - } - set chunk [read $inputchan] - #we expect a chan configured with -blocking 0 to be blocked immediately after reads - #test - just bug console for now - try to understand when/how/if a non blocking read occurs. - if {![chan blocked $inputchan]} { - puts stderr "repl_handler->$inputchan not blocked after read" - } + if {$readmore} { + if {[dict get $original_input_conf -blocking] ne "0" || [dict get $original_input_conf -translation] ne "lf"} { + chan configure $inputchan -blocking 0 + chan configure $inputchan -translation lf + } + set chunk [read $inputchan] + #we expect a chan configured with -blocking 0 to be blocked immediately after reads + #test - just bug console for now - try to understand when/how/if a non blocking read occurs. + if {![chan blocked $inputchan]} { + puts stderr "repl_handler->$inputchan not blocked after read" + } - punk::repl::repl_handler_restorechannel_if_not_eof $inputchan $original_input_conf - uplevel #0 [list repl::repl_process_data $inputchan raw-read $chunk [list] $prompt_config] + punk::repl::repl_handler_restorechannel_if_not_eof $inputchan $original_input_conf + uplevel #0 [list repl::repl_process_data $inputchan raw-read $chunk [list] $prompt_config] + } while {[llength $input_chunks_waiting($inputchan)]} { set chunkzero [lpop input_chunks_waiting($inputchan) 0] if {$chunkzero eq ""} {continue} ;#why empty waiting - and is there any point passing on? @@ -1604,33 +1648,35 @@ proc repl::repl_handler {inputchan prompt_config} { } } - if {![chan eof $inputchan]} { - ################################################################################## - #Re-enable channel read handler only if no waiting chunks - must process in order - ################################################################################## - if {![llength $input_chunks_waiting($inputchan)]} { - chan event $inputchan readable [list ::repl::repl_handler $inputchan $prompt_config] + if {$readmore} { + if {![chan eof $inputchan]} { + ################################################################################## + #Re-enable channel read handler only if no waiting chunks - must process in order + ################################################################################## + if {![llength $input_chunks_waiting($inputchan)]} { + chan event $inputchan readable [list ::repl::repl_handler $inputchan $readmore $prompt_config] + } else { + #review + #puts stderr "warning: after idle re-enable repl::repl_handler in thread: [thread::id]" + after idle [list ::repl::repl_handler $inputchan $readmore $prompt_config] + } + #################################################### } else { - #review - #puts stderr "warning: after idle re-enable repl::repl_handler in thread: [thread::id]" - after idle [list ::repl::repl_handler $inputchan $prompt_config] - } - #################################################### - } else { - #repl_handler_checkchannel $inputchan - chan event $inputchan readable {} - set reading 0 - #target is the 'main' interp in codethread. - #(note bug where thread::send goes to code interp, but thread::send -async goes to main interp) - # https://core.tcl-lang.org/thread/tktview/0de73f04c7ce188b13a4 - - thread::send -async $::repl::codethread {set ::punk::repl::codethread::is_running 0} ;#to main interp of codethread - if {$::tcl_interactive} { - rputs stderr "\nrepl_handler EOF inputchannel:[chan conf $inputchan]" - #rputs stderr "\n|repl> ctrl-c EOF on $inputchan." + #repl_handler_checkchannel $inputchan + chan event $inputchan readable {} + set reading 0 + #target is the 'main' interp in codethread. + #(note bug where thread::send goes to code interp, but thread::send -async goes to main interp) + # https://core.tcl-lang.org/thread/tktview/0de73f04c7ce188b13a4 + + thread::send -async $::repl::codethread {set ::punk::repl::codethread::is_running 0} ;#to main interp of codethread + if {$::tcl_interactive} { + rputs stderr "\nrepl_handler EOF inputchannel:[chan conf $inputchan]" + #rputs stderr "\n|repl> ctrl-c EOF on $inputchan." + } + set [namespace current]::done 1 + after 1 [list repl::reopen_stdin] } - set [namespace current]::done 1 - after 1 [list repl::reopen_stdin] } set in_repl_handler [list] } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm index 5d2a2725..16f6f1cb 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm @@ -218,7 +218,7 @@ namespace eval punk::repo { if {$fossilcmd eq "commit"} { if {[llength [file split $fosroot]]} { if {[file exists [file join $fosroot src/buildsuites]]} { - puts stderr "Todo - check buildsites/suite/projects for current branch/tag and update download_and_build_config" + puts stderr "Todo - check buildsuites/suite/projects for current branch/tag and update download_and_build_config" } } } elseif {$fossilcmd in [list "info" "status"]} { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.2.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.2.1.tm index 8e59cf0b..2eb2f8fa 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.2.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.2.1.tm @@ -2472,7 +2472,14 @@ namespace eval shellfilter { set exitinfo [list error "$errMsg" errorCode $::errorCode errorInfo "$::errorInfo"] } } + #puts "shellfilter::run finished call" + #------------------------- + #warning - without flush stdout - we can get hang, but only on some terminals + # - mechanism for this problem not understood! + flush stdout + flush stderr + #------------------------- #the previous redirections on the underlying inchan/outchan/errchan items will be restored from the -aside setting during removal #Remove execution-time Tees from stack @@ -2480,6 +2487,7 @@ namespace eval shellfilter { shellfilter::stack::remove stderr $id_err #shellfilter::stack::remove stderr $id_in + #puts stderr "shellfilter::run complete..." #chan configure stderr -buffering line #flush stdout diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellrun-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellrun-0.1.1.tm index 478c70fa..c3f7ab10 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellrun-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellrun-0.1.1.tm @@ -187,10 +187,10 @@ namespace eval shellrun { #--------------------------------------------------------------------------------------------- set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none ] #--------------------------------------------------------------------------------------------- - foreach id $idlist_stderr { shellfilter::stack::remove stderr $id } + #puts stderr "shellrun::run exitinfo: $exitinfo" flush stderr flush stdout diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/test/tomlish-1.1.5.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/test/tomlish-1.1.5.tm index 3ae60d42..f4f2b484 100644 Binary files a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/test/tomlish-1.1.5.tm and b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/test/tomlish-1.1.5.tm differ diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config index 0ea2f344..8ea31ad3 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config @@ -19,6 +19,7 @@ set bootsupport_modules [list\ src/vendormodules metaface\ src/vendormodules modpod\ src/vendormodules overtype\ + src/vendormodules packagetest\ src/vendormodules pattern\ src/vendormodules patterncmd\ src/vendormodules patternlib\ diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/packagetest-0.1.7.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/packagetest-0.1.7.tm new file mode 100644 index 00000000..658d45a4 Binary files /dev/null and b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/packagetest-0.1.7.tm differ diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/patterncipher-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/patterncipher-0.1.1.tm index 62b03cbc..0aa12476 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/patterncipher-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/patterncipher-0.1.1.tm @@ -37,7 +37,6 @@ package provide patterncipher [namespace eval patterncipher { package require ascii85 ;#tcllib package require pattern -::pattern::init ;# initialises (if not already) namespace eval ::patterncipher { namespace eval algo::txt { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.5.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.5.tm index db369f06..5138ac6d 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.5.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.5.tm @@ -2370,6 +2370,54 @@ namespace eval punk::lib { append body [info body is_list_all_ni_list2] proc is_list_all_ni_list2 {a b} $body } + proc is_cachedlist_all_ni_list {a b} { + upvar 0 ::punk::lib::caches::funcs_ni_list funcs + if {[info exists funcs($a)]} { + return [[set funcs($a)] $b] + } + set keybytes [encoding convertto utf-8 $a] + set key [binary encode base64 $keybytes] ;#one single-line base64 string + + set expression "" + foreach t $a { + #append expression "({$t} ni \$b) && " + append expression "{$t} ni \$b && " + } + set expression [string trimright $expression " &"] ;#trim trailing spaces and ampersands + proc ::punk::lib::caches::ni_list_$key {b} [string map [list @expression@ $expression] { + return [expr {@expression@}] + }] + + set funcs($a) ::punk::lib::caches::ni_list_$key + return [punk::lib::caches::ni_list_$key $b] + } + proc is_cachedlist_all_ni_list2 {a b} { + upvar 0 ::punk::lib::caches::funcs_ni_list funcs + if {[info exists funcs($a)]} { + return [[set funcs($a)] $b] + } + set keybytes [encoding convertto utf-8 $a] + set key [binary encode base64 $keybytes] ;#one single-line base64 string + + set d [dict create] + foreach x $a { + dict set d $x "" + } + #constructing a switch statement could be an option + # - but would need to avoid using escapes in order to get a jump-table + # - this would need runtime mapping of values - unlikely to be a win + proc ::punk::lib::caches::ni_list_$key {b} [string map [list @d@ $d] { + foreach x $b { + if {[::tcl::dict::exists {@d@} $x]} { + return 0 + } + } + return 1 + }] + + set funcs($a) ::punk::lib::caches::ni_list_$key + return [punk::lib::caches::ni_list_$key $b] + } namespace eval argdoc { variable PUNKARGS @@ -5389,6 +5437,10 @@ tcl::namespace::eval punk::lib::system { #[list_end] [comment {--- end definitions namespace punk::lib::system ---}] } +tcl::namespace::eval punk::lib::caches { + +} + tcl::namespace::eval punk::lib::debug { proc showdict {args} {} } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm index bcf2221f..59f23842 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm @@ -170,7 +170,16 @@ namespace eval punk::mix::commandset::module { @values -min 1 -max 1 module -type string -help\ "Name of module, possibly including a namespace and/or version number - e.g mynamespace::mymodule-1.0" + e.g mynamespace::mymodule-1.0 + + Some templates may require a prefixing namespace in order to function + correctly. e.g punk.test module names should be of the form + test::mymodule or test::mymodule::mycomponent + where the modules under test are mymodule and mymodule::mycomponent. + For example with test module test::a::b::c + The 'pkg' and 'pkgunprefixed' placeholders (surrounded by % char) are + filled with test::a::b::c and a::b::c respectively. + " }] proc new {args} { set year [clock format [clock seconds] -format %Y] @@ -222,6 +231,9 @@ namespace eval punk::mix::commandset::module { } else { set modulename $module } + #normalize modulename to remove any leading :: in case it was supplied that way + set modulename [string trimleft $modulename :] + punk::mix::cli::lib::validate_modulename $modulename -errorprefix "punk::mix::commandset::module::new" if {[regexp {[A-Z]} $module]} { @@ -410,7 +422,11 @@ namespace eval punk::mix::commandset::module { #for now the user has the option to override any templates and remove %moduletemplate% if it is a security/privacy concern #Don't put literal %x% in the code for the commandset::module itself - to stop them being seen by layout scanner as replacable tokens - set tagnames [list moduletemplate $moduletemplate project $projectname pkg $modulename year $year license $opt_license authors $opt_authors version $infile_version] + #JJJ + set pkg_parts [punk::ns::nsparts $modulename] ;#(modulename known not to have leading :: at this point) + set pkg_unprefixed [join [lrange $pkg_parts 1 end] ::] + #pkg_unprefixed may be empty - irrelevant for most templates but not ok for punk.test template - but where to reject? review + set tagnames [list moduletemplate $moduletemplate project $projectname pkg $modulename pkgunprefixed $pkg_unprefixed year $year license $opt_license authors $opt_authors version $infile_version] set strmap [list] foreach {tag val} $tagnames { lappend strmap %$tag% $val diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm index 0272500d..486720e8 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm @@ -479,7 +479,13 @@ proc repl::start {inchan args} { puts stderr "-->repl::start active on $inchan $args replthread:[thread::id] codethread:$codethread" set prompt_config [punk::repl::get_prompt_config] doprompt "P% " - chan event $inchan readable [list [namespace current]::repl_handler $inchan $prompt_config] + if {[llength $input_chunks_waiting($inchan)]} { + set readmore 0 + uplevel #0 [list [namespace current]::repl_handler $inchan $readmore $prompt_config] + #after 0 [list [namespace current]::repl_handler $inchan $readmore $prompt_config] + } + set readmore 1 + chan event $inchan readable [list [namespace current]::repl_handler $inchan $readmore $prompt_config] set reading 1 #catch { @@ -530,6 +536,22 @@ proc repl::start {inchan args} { #puts stderr "__> returning 0" return 0 } + +#put a script into the waiting buffer for evaluation +proc repl::submit {inputchan script} { + set prompt_config [punk::repl::get_prompt_config] + upvar ::punk::console::input_chunks_waiting input_chunks_waiting + if {[info exists input_chunks_waiting($inputchan)] && [llength $input_chunks_waiting($inputchan)]} { + set last [lindex $input_chunks_waiting($inputchan) end] + append last $script + lset input_chunks_waiting($inputchan) end $last + } else { + set input_chunks_waiting($inputchan) [list $script] + } + + #set readmore 0 + #after idle [list after 0 [list ::repl::repl_handler $inputchan $readmore $prompt_config]] +} proc repl::post_operations {} { if {[info exists ::repl::post_script] && [string length $::repl::post_script]} { #put aside post_script so the script has the option to add another post_script and restart the repl @@ -1384,7 +1406,10 @@ proc punk::repl::repl_handler_restorechannel_if_not_eof {inputchan previous_inpu } return [chan conf $inputchan] } -proc repl::repl_handler {inputchan prompt_config} { +proc repl::repl_handler {inputchan readmore prompt_config} { + #readmore set to zero used to process input_chunks_waiting without reading inputchan, + # and without rescheduling reader + # -- review variable in_repl_handler set in_repl_handler [list $inputchan $prompt_config] @@ -1451,115 +1476,132 @@ proc repl::repl_handler {inputchan prompt_config} { set waitingchunk [lindex $waitinglines end] # -- #set chunksize [gets $inputchan chunk] - set chunk [read $inputchan] - set chunksize [string length $chunk] - # -- - if {$chunksize > 0} { - if {[string index $chunk end] eq "\n"} { - lappend stdinlines $waitingchunk[string range $chunk 0 end-1] - #punk::console::cursorsave_move_emitblock_return 30 30 "repl_handler num_stdinlines [llength $stdinlines] chunk:$yellow[ansistring VIEW -lf 1 $chunk][a] fblocked:[fblocked $inputchan] pending:[chan pending input stdin]" - - punk::repl::repl_handler_restorechannel_if_not_eof $inputchan $original_input_conf - uplevel #0 [list repl::repl_process_data $inputchan line "" $stdinlines $prompt_config] - } else { - set input_chunks_waiting($inputchan) [list $allwaiting] - lappend input_chunks_waiting($inputchan) $chunk - } + if {!$readmore} { + set chunk "" + set chunksize 0 + uplevel #0 [list repl::repl_process_data $inputchan line "" $stdinlines $prompt_config] + set input_chunks_waiting($inputchan) [list $waitingchunk] } else { - #'chan blocked' docs state: 'Note that this only ever returns 1 when the channel has been configured to be non-blocking..' - if {[chan blocked $inputchan]} { - #REVIEW - - #todo - figure out why we're here. - #can we even put a spinner so we don't keep emitting lines? We probably can't use any ansi functions that need to get a response on stdin..(like get_cursor_pos) - #punk::console::get_size is problematic if -winsize not available on the stdout channel - which is the case for certain 8.6 versions at least.. platform variances? - ## can't do this: set screeninfo [punk::console::get_size]; lassign $screeninfo _c cols _r rows - set outconf [chan configure stdout] - set RED [punk::ansi::a+ red bold]; set RST [punk::ansi::a] - if {"windows" eq $::tcl_platform(platform)} { - set msg "${RED}$inputchan chan blocked is true. (line-length Tcl windows channel bug?)$RST \{$allwaiting\}" + set chunk [read $inputchan] + set chunksize [string length $chunk] + if {$chunksize > 0} { + if {[string index $chunk end] eq "\n"} { + lappend stdinlines $waitingchunk[string range $chunk 0 end-1] + #punk::console::cursorsave_move_emitblock_return 30 30 "repl_handler num_stdinlines [llength $stdinlines] chunk:$yellow[ansistring VIEW -lf 1 $chunk][a] fblocked:[fblocked $inputchan] pending:[chan pending input stdin]" + + punk::repl::repl_handler_restorechannel_if_not_eof $inputchan $original_input_conf + uplevel #0 [list repl::repl_process_data $inputchan line "" $stdinlines $prompt_config] } else { - set msg "${RED}$inputchan chan blocked is true.$RST \{$allwaiting\}" + set input_chunks_waiting($inputchan) [list $allwaiting] + lappend input_chunks_waiting($inputchan) $chunk } - set cols "" - set rows "" - if {[dict exists $outconf -winsize]} { - lassign [dict get $outconf -winsize] cols rows - } else { - #fallback - try external executable. Which is a bit ugly - #tput can't seem to get dimensions (on FreeBSD at least) when not run interactively - ie via exec. (always returns 80x24 no matter if run with <@stdin) - - #bizarrely - tput can work with exec on windows if it's installed e.g from msys2 - #but can be *slow* compared to unix e.g 400ms+ vs <2ms on FreeBSD ! - #stty -a is 400ms+ vs 500us+ on FreeBSD - + } else { + if {[chan blocked $inputchan]} { + #'chan blocked' docs state: 'Note that this only ever returns 1 when the channel has been configured to be non-blocking..' + #REVIEW - + #todo - figure out why we're here. + #can we even put a spinner so we don't keep emitting lines? We probably can't use any ansi functions that need to get a response on stdin..(like get_cursor_pos) + #punk::console::get_size is problematic if -winsize not available on the stdout channel - which is the case for certain 8.6 versions at least.. platform variances? + ## can't do this: set screeninfo [punk::console::get_size]; lassign $screeninfo _c cols _r rows + set outconf [chan configure stdout] + set RED [punk::ansi::a+ red bold]; set RST [punk::ansi::a] if {"windows" eq $::tcl_platform(platform)} { - set tputcmd [auto_execok tput] - if {$tputcmd ne ""} { - if {![catch {exec {*}$tputcmd cols lines} values]} { - lassign $values cols rows - } - } + set msg "${RED}$inputchan chan blocked is true. (line-length Tcl windows channel bug?)$RST \{$allwaiting\}" + } else { + set msg "${RED}$inputchan chan blocked is true.$RST \{$allwaiting\}" } + set cols "" + set rows "" + if {[dict exists $outconf -winsize]} { + lassign [dict get $outconf -winsize] cols rows + } else { + #fallback1 query terminal + if {![catch {punk::console::get_size} sdict]} { + set cols [dict get $sdict columns] + set rows [dict get $sdict rows] + } + + if {![string is integer -strict $cols] || ![string is integer -strict $rows]} { + + #fallback2 - try external executable. Which is a bit ugly + #tput can't seem to get dimensions (on FreeBSD at least) when not run interactively - ie via exec. (always returns 80x24 no matter if run with <@stdin) + + #bizarrely - tput can work with exec on windows if it's installed e.g from msys2 + #but can be *slow* compared to unix e.g 400ms+ vs <2ms on FreeBSD ! + #stty -a is 400ms+ vs 500us+ on FreeBSD - if {![string is integer -strict $cols] || ![string is integer -strict $rows]} { - #same for all platforms? tested on windows, wsl, FreeBSD - #exec stty -a gives a result on the first line like: - #speed xxxx baud; rows rr; columns cc; - #review - more robust parsing - do we know it's first line? - set sttycmd [auto_execok stty] - if {$sttycmd ne ""} { - #the more parseable: stty -g doesn't give rows/columns - if {![catch {exec {*}$sttycmd -a} result]} { - lassign [split $result \n] firstline - set lineparts [split $firstline {;}] ;#we seem to get segments that look well behaved enough to be treated as tcl lists - review - regex? - set rowinfo [lsearch -index end -inline $lineparts rows] - if {[llength $rowinfo] == 2} { - set rows [lindex $rowinfo 0] + if {"windows" eq $::tcl_platform(platform)} { + set tputcmd [auto_execok tput] + if {$tputcmd ne ""} { + if {![catch {exec {*}$tputcmd cols lines} values]} { + lassign $values cols rows + } } - set colinfo [lsearch -index end -inline $lineparts columns] - if {[llength $colinfo] == 2} { - set cols [lindex $colinfo 0] + } + + if {![string is integer -strict $cols] || ![string is integer -strict $rows]} { + #same for all platforms? tested on windows, wsl, FreeBSD + #exec stty -a gives a result on the first line like: + #speed xxxx baud; rows rr; columns cc; + #review - more robust parsing - do we know it's first line? + set sttycmd [auto_execok stty] + if {$sttycmd ne ""} { + #the more parseable: stty -g doesn't give rows/columns + if {![catch {exec {*}$sttycmd -a} result]} { + lassign [split $result \n] firstline + set lineparts [split $firstline {;}] ;#we seem to get segments that look well behaved enough to be treated as tcl lists - review - regex? + set rowinfo [lsearch -index end -inline $lineparts rows] + if {[llength $rowinfo] == 2} { + set rows [lindex $rowinfo 0] + } + set colinfo [lsearch -index end -inline $lineparts columns] + if {[llength $colinfo] == 2} { + set cols [lindex $colinfo 0] + } + } } } } } - } - if {[string is integer -strict $cols] && [string is integer -strict $rows]} { - #got_dimensions - todo - try spinner? - #puts -nonewline stdout [punk::ansi::move $rows 4]$msg - #use cursorsave_ version which avoids get_cursor_pos_list call - set msglen [ansistring length $msg] - punk::console::cursorsave_move_emitblock_return $rows [expr {$cols - $msglen -1}] $msg ;#supports also vt52 - } else { - #no mechanism to get console dimensions - #we are reduced to continuously spewing lines. - puts stderr $msg - } + if {[string is integer -strict $cols] && [string is integer -strict $rows]} { + #got_dimensions - todo - try spinner? + #puts -nonewline stdout [punk::ansi::move $rows 4]$msg + #use cursorsave_ version which avoids get_cursor_pos_list call + set msglen [ansistring length $msg] + punk::console::cursorsave_move_emitblock_return $rows [expr {$cols - $msglen -1}] $msg ;#supports also vt52 + } else { + #no mechanism to get console dimensions + #we are reduced to continuously spewing lines. + puts stderr $msg + } - after 100 + after 100 + } + set input_chunks_waiting($inputchan) [list $allwaiting] } - set input_chunks_waiting($inputchan) [list $allwaiting] } - + # -- } else { - punk::repl::repl_handler_checkchannel $inputchan - punk::repl::repl_handler_checkcontrolsignal_linemode $inputchan - # -- --- --- - #set chunksize [gets $inputchan chunk] - # -- --- --- - set chunk [read $inputchan] - set chunksize [string length $chunk] - # -- --- --- - if {$chunksize > 0} { - #punk::console::cursorsave_move_emitblock_return 35 120 "chunk: [ansistring VIEW -lf 1 "...[string range $chunk end-10 end]"]" - set ln $chunk ;#temp - #punk::console::cursorsave_move_emitblock_return 25 30 [textblock::frame -title line "[a+ green]$waitingchunk[a][a+ red][ansistring VIEW -lf 1 $ln][a+ green]pending:[chan pending input stdin][a]"] - if {[string index $ln end] eq "\n"} { - lappend stdinlines [string range $ln 0 end-1] - punk::repl::repl_handler_restorechannel_if_not_eof $inputchan $original_input_conf - uplevel #0 [list repl::repl_process_data $inputchan line "" $stdinlines $prompt_config] - } else { - lappend input_chunks_waiting($inputchan) $ln + if {$readmore} { + punk::repl::repl_handler_checkchannel $inputchan + punk::repl::repl_handler_checkcontrolsignal_linemode $inputchan + # -- --- --- + #set chunksize [gets $inputchan chunk] + # -- --- --- + set chunk [read $inputchan] + set chunksize [string length $chunk] + # -- --- --- + if {$chunksize > 0} { + #punk::console::cursorsave_move_emitblock_return 35 120 "chunk: [ansistring VIEW -lf 1 "...[string range $chunk end-10 end]"]" + set ln $chunk ;#temp + #punk::console::cursorsave_move_emitblock_return 25 30 [textblock::frame -title line "[a+ green]$waitingchunk[a][a+ red][ansistring VIEW -lf 1 $ln][a+ green]pending:[chan pending input stdin][a]"] + if {[string index $ln end] eq "\n"} { + lappend stdinlines [string range $ln 0 end-1] + punk::repl::repl_handler_restorechannel_if_not_eof $inputchan $original_input_conf + uplevel #0 [list repl::repl_process_data $inputchan line "" $stdinlines $prompt_config] + } else { + lappend input_chunks_waiting($inputchan) $ln + } } } } @@ -1582,19 +1624,21 @@ proc repl::repl_handler {inputchan prompt_config} { } if {$continue} { - if {[dict get $original_input_conf -blocking] ne "0" || [dict get $original_input_conf -translation] ne "lf"} { - chan configure $inputchan -blocking 0 - chan configure $inputchan -translation lf - } - set chunk [read $inputchan] - #we expect a chan configured with -blocking 0 to be blocked immediately after reads - #test - just bug console for now - try to understand when/how/if a non blocking read occurs. - if {![chan blocked $inputchan]} { - puts stderr "repl_handler->$inputchan not blocked after read" - } + if {$readmore} { + if {[dict get $original_input_conf -blocking] ne "0" || [dict get $original_input_conf -translation] ne "lf"} { + chan configure $inputchan -blocking 0 + chan configure $inputchan -translation lf + } + set chunk [read $inputchan] + #we expect a chan configured with -blocking 0 to be blocked immediately after reads + #test - just bug console for now - try to understand when/how/if a non blocking read occurs. + if {![chan blocked $inputchan]} { + puts stderr "repl_handler->$inputchan not blocked after read" + } - punk::repl::repl_handler_restorechannel_if_not_eof $inputchan $original_input_conf - uplevel #0 [list repl::repl_process_data $inputchan raw-read $chunk [list] $prompt_config] + punk::repl::repl_handler_restorechannel_if_not_eof $inputchan $original_input_conf + uplevel #0 [list repl::repl_process_data $inputchan raw-read $chunk [list] $prompt_config] + } while {[llength $input_chunks_waiting($inputchan)]} { set chunkzero [lpop input_chunks_waiting($inputchan) 0] if {$chunkzero eq ""} {continue} ;#why empty waiting - and is there any point passing on? @@ -1604,33 +1648,35 @@ proc repl::repl_handler {inputchan prompt_config} { } } - if {![chan eof $inputchan]} { - ################################################################################## - #Re-enable channel read handler only if no waiting chunks - must process in order - ################################################################################## - if {![llength $input_chunks_waiting($inputchan)]} { - chan event $inputchan readable [list ::repl::repl_handler $inputchan $prompt_config] + if {$readmore} { + if {![chan eof $inputchan]} { + ################################################################################## + #Re-enable channel read handler only if no waiting chunks - must process in order + ################################################################################## + if {![llength $input_chunks_waiting($inputchan)]} { + chan event $inputchan readable [list ::repl::repl_handler $inputchan $readmore $prompt_config] + } else { + #review + #puts stderr "warning: after idle re-enable repl::repl_handler in thread: [thread::id]" + after idle [list ::repl::repl_handler $inputchan $readmore $prompt_config] + } + #################################################### } else { - #review - #puts stderr "warning: after idle re-enable repl::repl_handler in thread: [thread::id]" - after idle [list ::repl::repl_handler $inputchan $prompt_config] - } - #################################################### - } else { - #repl_handler_checkchannel $inputchan - chan event $inputchan readable {} - set reading 0 - #target is the 'main' interp in codethread. - #(note bug where thread::send goes to code interp, but thread::send -async goes to main interp) - # https://core.tcl-lang.org/thread/tktview/0de73f04c7ce188b13a4 - - thread::send -async $::repl::codethread {set ::punk::repl::codethread::is_running 0} ;#to main interp of codethread - if {$::tcl_interactive} { - rputs stderr "\nrepl_handler EOF inputchannel:[chan conf $inputchan]" - #rputs stderr "\n|repl> ctrl-c EOF on $inputchan." + #repl_handler_checkchannel $inputchan + chan event $inputchan readable {} + set reading 0 + #target is the 'main' interp in codethread. + #(note bug where thread::send goes to code interp, but thread::send -async goes to main interp) + # https://core.tcl-lang.org/thread/tktview/0de73f04c7ce188b13a4 + + thread::send -async $::repl::codethread {set ::punk::repl::codethread::is_running 0} ;#to main interp of codethread + if {$::tcl_interactive} { + rputs stderr "\nrepl_handler EOF inputchannel:[chan conf $inputchan]" + #rputs stderr "\n|repl> ctrl-c EOF on $inputchan." + } + set [namespace current]::done 1 + after 1 [list repl::reopen_stdin] } - set [namespace current]::done 1 - after 1 [list repl::reopen_stdin] } set in_repl_handler [list] } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm index 5d2a2725..16f6f1cb 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm @@ -218,7 +218,7 @@ namespace eval punk::repo { if {$fossilcmd eq "commit"} { if {[llength [file split $fosroot]]} { if {[file exists [file join $fosroot src/buildsuites]]} { - puts stderr "Todo - check buildsites/suite/projects for current branch/tag and update download_and_build_config" + puts stderr "Todo - check buildsuites/suite/projects for current branch/tag and update download_and_build_config" } } } elseif {$fossilcmd in [list "info" "status"]} { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.2.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.2.1.tm index 8e59cf0b..2eb2f8fa 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.2.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.2.1.tm @@ -2472,7 +2472,14 @@ namespace eval shellfilter { set exitinfo [list error "$errMsg" errorCode $::errorCode errorInfo "$::errorInfo"] } } + #puts "shellfilter::run finished call" + #------------------------- + #warning - without flush stdout - we can get hang, but only on some terminals + # - mechanism for this problem not understood! + flush stdout + flush stderr + #------------------------- #the previous redirections on the underlying inchan/outchan/errchan items will be restored from the -aside setting during removal #Remove execution-time Tees from stack @@ -2480,6 +2487,7 @@ namespace eval shellfilter { shellfilter::stack::remove stderr $id_err #shellfilter::stack::remove stderr $id_in + #puts stderr "shellfilter::run complete..." #chan configure stderr -buffering line #flush stdout diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellrun-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellrun-0.1.1.tm index 478c70fa..c3f7ab10 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellrun-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellrun-0.1.1.tm @@ -187,10 +187,10 @@ namespace eval shellrun { #--------------------------------------------------------------------------------------------- set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none ] #--------------------------------------------------------------------------------------------- - foreach id $idlist_stderr { shellfilter::stack::remove stderr $id } + #puts stderr "shellrun::run exitinfo: $exitinfo" flush stderr flush stdout diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/test/tomlish-1.1.5.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/test/tomlish-1.1.5.tm index 3ae60d42..f4f2b484 100644 Binary files a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/test/tomlish-1.1.5.tm and b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/test/tomlish-1.1.5.tm differ diff --git a/src/scriptapps/bin/getzig.bash b/src/scriptapps/bin/getzig.bash index 860e2767..f57e914b 100644 --- a/src/scriptapps/bin/getzig.bash +++ b/src/scriptapps/bin/getzig.bash @@ -1,12 +1,17 @@ #mkdir -p ./zig -#tarball="zig-x86_64-windows-0.15.1.zip" -#tarball="zig-x86_64-freebsd-0.15.1.tar.xz" -tarball="zig-x86_64-linux-0.15.1.tar.xz" +#tarball="zig-x86_64-windows-0.15.2.zip" +#tarball="zig-x86_64-freebsd-0.15.2.tar.xz" +tarball="zig-x86_64-linux-0.15.2.tar.xz" automation_name="punkshell+julian@precisium.com.au_target_by_latency" uristring="https://ziglang.org" -full_uristring="${uristring}/download/0.15.1/${tarball}?source=${automation_name}" + +#releases +full_uristring="${uristring}/download/0.15.2/${tarball}?source=${automation_name}" +#pre-releases +#full_uristring="${uristring}/builds/${tarball}?source=${automation_name}" + echo "Unimplemented: Download from ${full_uristring} and extract manually" #wget $full_uristring -O ./zig/zig-linux-x86_64-0.10.1.tar.xz #tar -xf ./zig/zig-linux-x86_64-0.10.1.tar.xz -C ./zig --strip-components=1 diff --git a/src/scriptapps/bin/getzig.ps1 b/src/scriptapps/bin/getzig.ps1 index 7c185901..712633dd 100644 --- a/src/scriptapps/bin/getzig.ps1 +++ b/src/scriptapps/bin/getzig.ps1 @@ -15,8 +15,10 @@ if (-not(Test-Path -Path $toolsfolder -PathType Container)) { } $zigfolder = Join-Path $toolsfolder -ChildPath "zig" $zigexe = Join-Path $zigfolder -ChildPath "zig.exe" -# $releasearchive = "zig-x86_64-windows-0.15.1.zip" ;#zip on windows, tarball on every other platform -$releasearchive = "zig-x86_64-windows-0.16.0-dev.254+6dd0270a1.zip" +#$releasearchive = "zig-x86_64-windows-0.15.1.zip" ;#zip on windows, tarball on every other platform +#$releasearchive = "zig-x86_64-windows-0.16.0-dev.254+6dd0270a1.zip" +#$releasearchive = "zig-x86_64-windows-0.16.0-dev.2193+fc517bd01.zip" +$releasearchive = "zig-x86_64-windows-0.15.2.zip" Write-Output "powershell version: $($PSVersionTable.PSVersion)" if (Get-Command $zigexe -ErrorAction SilentlyContinue) { @@ -207,7 +209,10 @@ if (-not $download_required) { exit 0 } +#index: https://ziglang.org/download/index.json + $mirrors_url = "https://ziglang.org/download/community-mirrors.txt" +#some mirrors have no index and the base url will produce a 404, some have an html index, some have a modified copy of the ziglang.org/download/index.json $mirrors_response = $(Invoke-WebRequest -Uri $mirrors_url) if ($mirrors_response.StatusCode -eq 200) { #https://www.gitea1.intx.com.au/jn/punkbin/raw/branch/master/win32-x86_64/tools/zig-x86_64-windows-0.15.1.zip @@ -306,8 +311,10 @@ if ($mirrors_response.StatusCode -eq 200) { foreach ($hostinfo in $sorted_mirror_dicts) { $uristring = $hostinfo.uri if ($uristring -eq "https://ziglang.org") { + #if it's a release $full_uristring = "${uristring}/download/0.15.1/${releasearchive}?source=${automation_name}" $sig_uristring = "${uristring}/download/0.15.1/${releasearchive}.minisig?source=${automation_name}" + #if it's a pre-release?? /builds/${prereleasearchive} ? } else { $full_uristring = "${uristring}/${releasearchive}?source=${automation_name}" $sig_uristring = "${uristring}/${releasearchive}.minisig?source=${automation_name}" diff --git a/src/vendormodules/include_modules.config b/src/vendormodules/include_modules.config index da89717f..92343fb5 100644 --- a/src/vendormodules/include_modules.config +++ b/src/vendormodules/include_modules.config @@ -2,11 +2,10 @@ #aim is to be programatically editable whilst retaining comments set local_modules [list\ - c:/repo/nonexistant/tclmodules/blah/modules blah\ c:/repo/jn/tclmodules/fauxlink/modules fauxlink\ c:/repo/jn/tclmodules/gridplus/modules gridplus\ c:/repo/jn/tclmodules/modpod/modules modpod\ - c:/repo/jn/tclmodules/packageTest/modules packageTest\ + c:/repo/jn/tclmodules/packageTest/modules packagetest\ c:/repo/jn/tclmodules/tablelist/modules tablelist\ c:/repo/jn/tclmodules/tablelist/modules tablelist_tile\ c:/repo/jn/tclmodules/tomlish/modules tomlish\ @@ -14,6 +13,7 @@ set local_modules [list\ c:/repo/jn/tclmodules/dictn/modules dictn\ c:/repo/jn/tclmodules/dollarcent/modules dollarcent\ c:/repo/jn/tclmodules/pattern/modules pattern\ + c:/repo/jn/tclmodules/pattern/modules pattern2\ c:/repo/jn/tclmodules/pattern/modules patterncmd\ c:/repo/jn/tclmodules/pattern/modules patternlib\ c:/repo/jn/tclmodules/pattern/modules patterncipher\ @@ -22,6 +22,11 @@ set local_modules [list\ c:/repo/jn/tclmodules/pattern/modules patternpredator2\ c:/repo/jn/tclmodules/pattern/modules patterndispatcher\ c:/repo/jn/tclmodules/pattern/modules treeobj\ + c:/repo/jn/tclmodules/pattern/modules pattern::ms\ + c:/repo/jn/tclmodules/pattern/modules pattern::IPatternBuilder\ + c:/repo/jn/tclmodules/pattern/modules pattern::IPatternInterface\ + c:/repo/jn/tclmodules/pattern/modules pattern::IPatternSystem\ + c:/repo/jn/tclmodules/pattern/modules test::pattern\ c:/repo/jn/tarjar/modules tarjar\ ] diff --git a/src/vendormodules/packageTest-0.1.4.tm b/src/vendormodules/packageTest-0.1.4.tm deleted file mode 100644 index 36e42747..00000000 Binary files a/src/vendormodules/packageTest-0.1.4.tm and /dev/null differ diff --git a/src/vendormodules/packageTest-0.1.5.tm b/src/vendormodules/packageTest-0.1.5.tm deleted file mode 100644 index 3aba1ee9..00000000 Binary files a/src/vendormodules/packageTest-0.1.5.tm and /dev/null differ diff --git a/src/vendormodules/packagetest-0.1.7.tm b/src/vendormodules/packagetest-0.1.7.tm new file mode 100644 index 00000000..658d45a4 Binary files /dev/null and b/src/vendormodules/packagetest-0.1.7.tm differ diff --git a/src/vendormodules/pattern/IPatternBuilder-2.0.tm b/src/vendormodules/pattern/IPatternBuilder-2.0.tm new file mode 100644 index 00000000..35a56b5d --- /dev/null +++ b/src/vendormodules/pattern/IPatternBuilder-2.0.tm @@ -0,0 +1,326 @@ +package provide pattern::IPatternBuilder 2.0 + +#Definition of pattern interface with interface ID 'PatternBuilder' +#Execution context: pp::Obj${OID}::_meta namespace (varspace _meta) + +namespace eval pattern { +} + +package require TclOO + +oo::class create ::pattern::IPatternBuilder +oo::define ::pattern::IPatternBuilder { + variable o_OID +} + +oo::define ::pattern::IPatternBuilder method ID {} { + my variable o_OID + puts "IPatternBuilder returning id $o_OID" + return $o_OID +} +oo::define ::pattern::IPatternBuilder method do {script} { + eval $script +} +oo::define ::pattern::IPatternBuilder method test {} { + return [my ID] +} +oo::define ::pattern::IPatternBuilder method test2 {} { + return [my PatternBuilder.ID] +} +oo::define ::pattern::IPatternBuilder method test3 {} { + return "info level 0 = \[[info level 0]\]" +} + +oo::define ::pattern::IPatternBuilder forward test4 my API(varspace_meta)getmap + +#gather all varspaces from interfaces on this object +oo::define ::pattern::IPatternBuilder method (GET)Varspaces {} { + my variable o_OID + #set builtin_varspaces [list _ref _meta _main _iface _apimanager] + set raw_nslist [namespace children ::pp::Obj${o_OID}] + set spaces [list] + foreach ns $raw_nslist { + lappend spaces [namespace tail $ns] + } + return [concat main $spaces] +} + +#gather all varspaces from patterns +oo::define ::pattern::IPatternBuilder method (GET)PatternVarspaces {} { + +} + + +oo::define ::pattern::IPatternBuilder method Constructor {arglist body} { + my variable o_OID _ID_ o_pattern_apis o_interface_default_api + set invocants [dict get $_ID_ i] + + set apiname [set ::pp::Obj${o_OID}::_meta::o_interface_default_api] + + set istack [dict get $o_pattern_apis $apiname] + + set iid_top [lindex $patterns end] ;#!todo - choose 'open' interface to expand. + + set iface ::p::ifaces::>$iid_top + + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id + #set iid_top [::p::get_new_object_id] + + #the >interface constructor takes a list of IDs for o_usedby + set iface [::pp::>interface .. Create ::pp::ifaces::>$iid_top [set usedby [list $OID]] ] + + dict set o_pattern_apis $apiname [concat $patterns $iid_top] + } + set IID $iid_top + + namespace upvar ::pp::Obj${IID}::_iface o_open o_open o_constructor o_constructor o_varspace o_varspace + + + # examine the existing command-chain + set maxversion [::p::predator::method_chainhead $IID (CONSTRUCTOR)] + set headid [expr {$maxversion + 1}] + set THISNAME (CONSTRUCTOR).$headid ;#first version will be $method.1 + + #set next [::p::predator::next_script $IID (CONSTRUCTOR) $THISNAME $_ID_] + + #set varspaces [::pattern::varspace_list] + set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] + + if {[llength [dict get $processed explicitvars]]} { + set body [dict get $processed body] + } else { + set varDecls [::p::predator::runtime_vardecls] + set body $varDecls\n[dict get $processed body] + #puts stderr "\t runtime_vardecls in Constructor $varDecls" + } + + #set body [string map [::list @OID@ "\[lindex \[dict get \$_ID_ i this\] 0 0\]" @this@ "\[lindex \[dict get \[set ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::_meta::map\] invocantdata \] 3\]" @next@ $next] $body\n] + set body [string map [::list @OID@ "\[dict get \[lindex \[dict get \$_ID_ i this\] 0\] id\]" @this@ "\[dict get \[lindex \[dict get \$_ID_ i this\] 0\] id\]" @next@ error] $body\n] + + #puts stderr ---- + #puts stderr $body + #puts stderr ---- + + + + #proc ::p::${IID}::_iface::(CONSTRUCTOR).$headid [concat _ID_ $arglist] $body + #interp alias {} ::p::${IID}::_iface::(CONSTRUCTOR) {} ::p::${IID}::_iface::(CONSTRUCTOR).$headid + + + + set o_constructor [list $arglist $body] + set o_open 1 + + return +} + + + + + +oo::define ::pattern::IPatternBuilder method Method {method arglist bodydef args} { + my variable o_OID _ID_ + + set invocants [dict get $_ID_ i] + set invocant_signature [list] ; + ;# we sort when calculating the sig.. so a different key order will produce the same signature - !todo - this is probably desirable but review anyway. + foreach role [lsort [dict keys $invocants]] { + lappend invocant_signature $role [llength [dict get $invocants $role]] + } + #note: it's expected that by far the most common 'invocant signature' will be {this 1} - which corresponds to a standard method dispatch on a single invocant object - the 'subject' (aka 'this') + + set IID [::pp::predator::get_possibly_new_open_interface $o_OID] + + error "unimplemented" + +} + +oo::define ::pattern::IPatternBuilder method INFO {INVOCANTS} { + my variable _ID_ o_interface_apis o_pattern_apis o_invocantrecord o_interface_default_api o_pattern_default_api + + puts stderr "\tINVOCANTS:$INVOCANTS\n" + puts stderr "\t[info level 0]\n" + set result "" + append result "_ID_: $_ID_\n" + + set invocants [dict get $_ID_ i] + set invocant_roles [dict keys $invocants] + append result "invocant roles: $invocant_roles\n" + set total_invocants 0 + foreach key $invocant_roles { + incr total_invocants [llength [dict get $invocants $key]] + } + + append result "invocants: ($total_invocants invocant(s) in [llength $invocant_roles] role(s)) \n" + foreach key $invocant_roles { + append result "\t-------------------------------\n" + append result "\trole: $key\n" + set role_members [dict get $invocants $key] ;#usually the role 'this' will have 1 member - but roles can have any number of invocants + append result "\t Raw data for this role: $role_members\n" + append result "\t Number of invocants in this role: [llength $role_members]\n" + foreach member $role_members { + #set OID [lindex [dict get $invocants $key] 0 0] + set OID [lindex $member 0] + set OID [dict get $member id] + append result "\t\tOID: $OID\n" + #lassign $o_invocantrecord _OID namespace default_method cmd _wrapped + dict update o_invocantrecord id _OID ns namespace defaultmethod default_method object cmd {} + append result "\t\tNamespace: $namespace\n" + append result "\t\tDefault method: $default_method\n" + append result "\t\tCommand: $cmd\n" + append result "\t\tClass: [info object class $cmd]\n" + + append result "\t\tDefault API: $o_interface_default_api\n" + append result "\t\tinterface apis: \n" + foreach key [dict keys $o_interface_apis] { + append result "\t\t\tapi:'$key'\n" + append result "\t\t\t\t[dict get $o_interface_apis $key]\n" + } + #append result "\t\tDefault pattern API: $o_pattern_default_api\n" + append result "\t\tpattern apis: \n" + foreach key [dict keys $o_pattern_apis] { + append result "\t\t\tapi:'$key'\n" + append result "\t\t\t\t[dict get $o_pattern_apis $key]\n" + } + + } + append result "\n" + append result "\t-------------------------------\n" + } + + + + return $result +} + +oo::define ::pattern::IPatternBuilder method IFINFO {{api "default"}} { + my variable _ID_ o_OID o_interface_apis o_pattern_apis o_interface_default_api + if {$api eq "default"} { + set api $o_interface_default_api} + + if {$api eq "*"} { + set apilist [dict keys $o_interface_apis] + } else { + set apilist [list $api] + } + + puts stderr "\t _ID_ --$_ID_--" + set invocants [dict get $_ID_ i] + + foreach a $apilist { + puts stderr "\t------------------------------\n" + puts stderr "\t API:'$a'\n" + puts stderr "\t------------------------------\n" + set interfaces [dict get $o_interface_apis $a] + set IFID [lindex $interfaces 0] + if {![llength $interfaces]} { + puts stderr "No interfaces present for api:'$a'" + } else { + foreach IFID $interfaces { + set iface ::pp::ifaces::>$IFID + puts stderr "$iface : [$iface --]" + puts stderr "\tis open: [set ::pp::I${IFID}::_iface::o_open]" + set variables [set ::pp::I${IFID}::_iface::o_variables] + puts stderr "\tvariables: $variables" + } + } + puts stderr "\t------------------------------\n" + } +} + + +oo::define ::pattern::IPatternBuilder method Create {target_spec args} { + my variable _ID_ o_OID o_invocantrecord o_interface_apis o_pattern_apis o_interface_default_api + set invocants [dict get $_ID_ i] + set invocant_roles [dict keys $invocants] ;#usually the only invocant role present will be 'this' (single dispatch case) + + set api $o_interface_default_api + lassign $o_invocantrecord o_OID parent_ns parent_defaultmethod parent_object_command + set interfaces [dict get $o_interface_apis $api] ;#level-0 interfaces + set patterns [dict get $o_pattern_apis $api] ;#level-1 interfaces + + #set parent_patterndefaultmethod [dict get $map patterndata patterndefaultmethod] + + #todo - change to dict of interface stacks + set IFID0 [lindex $interfaces 0] + set IFID1 [lindex $patterns 0] ;#1st pattern + + if {[llength $target_spec] ==1} { + set child $target_spec + set targets [list $child {}] + } else { + set targets $target_spec + } + + + + + set target_objects [list] + foreach child [dict keys $targets] { + set target_spec_dict [dict get $targets $child] + if {![string match {::*} $child]} { + if {[set ns [uplevel 1 {namespace current}]] eq "::"} { + set child ::$child + } else { + set child ${ns}::$child + } + } + #add > character if not already present + set child [namespace qualifiers $child]::>[string trimleft [namespace tail $child] >] + + #maintain a record of interfaces created so that we can clean-up if we get an error during any of the Constructor calls. + set new_interfaces [list] + if {![llength $patterns]} { + #puts stderr "===> WARNING: no level-1 interfaces (patterns) on object $parent_object_command when creating $child" + set patterns [list [set iid [::pp::get_new_object_id]]] + lappend new_interfaces [::pp::func::new_object ::pp::ifaces::>$iid $iid] + } + + if {![llength [info commands $child]]} { + #usual case - target/child does not exist + set is_new_object 1 + if {[dict exists $target_spec_dict -id]} { + ::pp::func::new_object $child [dict get $target_spec_dict -id] + } else { + ::pp::func::new_object $child + } + set child_ID [$child ## varspace_meta . ID] + #set childmapdata [set ::pp::Obj${child_ID}::_meta::map] + #upvar #0 ::pp::Obj${child_ID}::_meta::map CHILDMAP + + $child ## varspace_meta . (SET)interfaces $patterns + + set ifaces_added $patterns + } else { + #child exists - overlay + set is_new_object 0 + set existing_interfaces [$child ## varspace_meta . (GET)interfaces] + set ifaces_added [list] + foreach p $patterns { + if {$p ni $existing_interfaces} { + lappend ifaces_added $p + } + } + if {[llength $ifaces_added]} { + $child ## varspace_meta . (SET)interfaces [concat $existing_interfaces $ifaces_added] + } + } + + #only set the child's defaultmethod value if the parent_patterndefaultmethod is not empty + #if {$parent_patterndefaultmethod ne ""} { + # $child ## PatternInternal . (SET)default_method $parent_patterndefaultmethod + #} + + lappend target_objects $child + } + return $target_objects +} + + +namespace eval ::pattern { + set tmp_methods [info class methods ::pattern::IPatternBuilder -private] ;#-private returns all user-defined methods above + oo::define ::pattern::IPatternBuilder export {*}$tmp_methods + unset tmp_methods +} \ No newline at end of file diff --git a/src/vendormodules/pattern/IPatternInterface-2.0.tm b/src/vendormodules/pattern/IPatternInterface-2.0.tm new file mode 100644 index 00000000..c4303c8d --- /dev/null +++ b/src/vendormodules/pattern/IPatternInterface-2.0.tm @@ -0,0 +1,43 @@ +package provide pattern::IPatternInterface 2.0 + +#Definition of pattern interface with interface ID 'Define' +#Execution context: pp::Obj${OID}::_meta namespace (varspace _meta) + +namespace eval pattern { +} + +package require TclOO + +oo::class create ::pattern::IPatternInterface + +oo::define ::pattern::IPatternInterface { + variable o_open +} + +oo::define ::pattern::IPatternInterface method isOpen {} { + my variable o_open + return $o_open +} +oo::define ::pattern::IPatternInterface method isClosed {} { + my variable o_open + return [expr {!$o_open}] +} + +oo::define ::pattern::IPatternInterface method getcmd {args} { + return $args +} +oo::define ::pattern::IPatternInterface method run {args} { + uplevel 1 {*}$args +} + +#this is not the object's implemented varspaces - it is the varspace list for the interface specification this object represents +oo::define ::pattern::IPatternInterface method Varspaces {args} { + tailcall my API(varspace_iface)(GET)interface_varspaces +} + + +namespace eval ::pattern { + set tmp_methods [info class methods ::pattern::IPatternInterface -private] ;#-private returns all user-defined methods above + oo::define ::pattern::IPatternInterface export {*}$tmp_methods + unset tmp_methods +} \ No newline at end of file diff --git a/src/vendormodules/pattern/IPatternSystem-2.0.tm b/src/vendormodules/pattern/IPatternSystem-2.0.tm new file mode 100644 index 00000000..68663e62 --- /dev/null +++ b/src/vendormodules/pattern/IPatternSystem-2.0.tm @@ -0,0 +1,122 @@ + +# +# +package provide pattern::IPatternSystem 2.0 + +#Definition of pattern interface with interface ID 'PatternSystem' +#Execution context: pp::Obj${OID}::_meta namespace (varspace _meta) + +namespace eval pattern { +} + +package require TclOO + +oo::class create ::pattern::IPatternSystem + +oo::define ::pattern::IPatternSystem { + variable o_OID +} + +oo::define ::pattern::IPatternSystem method ID {} { + my variable o_OID + puts "IPatternSystem returning id $o_OID" + return $o_OID +} + + +oo::define ::pattern::IPatternSystem method get_possibly_new_open_interface {{apiname default}} { + my variable o_OID _ID_ o_interface_apis + + + if {$apiname eq "default"} { + set apiname [set ::pp::Obj${o_OID}::_meta::o_default_interface_api] + } + if {![dict exists $o_interface_apis $apiname]} { + error "get_possibly_new_open_interface Unable to find api:'$apiname'" + } + + set interfaces [dict get $o_interface_apis $apiname] + set iid_top [lindex $interfaces end] + set iface ::pp::ifaces::>$iid_top + if {(![string length $iid_top]) || ([$iface . isClosed])} { + #no existing pattern - create a new interface + set iid_top [expr {$::pp::ID + 1}] ;#PREDICT the next object's id + #puts stderr ">>>>creating new interface $iid_top" + set iface [::pp::>interface .. Create ::pp::ifaces::>$iid_top $o_OID] + + dict set o_interface_apis $apiname [concat $interfaces $iid_top] + } + return $iid_top +} + + +oo::define ::pattern::IPatternSystem method add_pattern_interface {iid {apiname default}} { + my variable _ID_ o_pattern_apis + #puts stderr "!!!!!!!!!!!!!!! add_pattern_interface $iid" + if {![string is integer -strict $iid]} { + error "add_pattern_interface adding interface by name not yet supported. Please use integer id" + } + + + if {$apiname eq "default"} { + set apiname [set ::pp::Obj${o_OID}::_meta::o_default_pattern_api] + } + if {![dict exists $o_pattern_apis $apiname]} { + error "add_interface Unable to find api:'$apiname'" + } + + + #set invocants [dict get $_ID_ i] + + set istack [dict get $o_pattern_apis $apiname] + + #it is theoretically possible to have the same interface present multiple times in an iStack. + # #!todo -review why/whether this is useful. should we disallow it and treat as an error? + dict set o_pattern_apis $apiname [concat $istack $iid] + + + + +} + + + +#!todo - update usedby ?? +oo::define ::pattern::IPatternSystem method add_interface {iid {apiname default}} { + my variable o_OID _ID_ o_interface_apis + if {![string is integer -strict $iid]} { + error "adding interface by name not yet supported. Please use integer id" + } + + + if {$apiname eq "default"} { + set apiname [set ::pp::Obj${o_OID}::_meta::o_default_interface_api] + } + if {![dict exists $o_interface_apis $apiname]} { + error "add_interface Unable to find api:'$apiname'" + } + + + lassign [dict get $_ID_ i this] list_of_invocants_for_role_this ;#Although there is normally only 1 'this' element - it is a 'role' and the structure is nonetheless a list. + set this_invocant [lindex $list_of_invocants_for_role_this 0] + lassign $this_invocant OID _etc + + set istack [dict get $o_interface_apis $apiname] + dict set o_interface_apis $apiname [concat $istack $iid] + + return [dict get $o_interface_apis $apiname] +} + + +oo::define ::pattern::IPatternSystem method INVOCANTDATA {} { + my variable _ID_ + #same as a call to: >object .. + return $_ID_ +} + + +namespace eval ::pattern { + set tmp_methods [info class methods ::pattern::IPatternSystem -private] ;#-private returns all user-defined methods above + oo::define ::pattern::IPatternSystem export {*}$tmp_methods + unset tmp_methods +} \ No newline at end of file diff --git a/src/vendormodules/pattern/ms-1.0.12.tm b/src/vendormodules/pattern/ms-1.0.12.tm new file mode 100644 index 00000000..09a4a005 --- /dev/null +++ b/src/vendormodules/pattern/ms-1.0.12.tm @@ -0,0 +1,330 @@ +#JMN 2007 +#public domain + +#experimental +#VERY incomplete + +package require pattern +package require patternlib +package require struct::set + +package provide pattern::ms [namespace eval ::pattern::ms { + variable version + set version 1.0.12 +}] + + +#-------------------------------------------------- +namespace eval ::pattern::ms { + ::>pattern .. Create >IEnumerable + >IEnumerable .. PatternVariable i ;#current index + >IEnumerable .. PatternProperty Current + >IEnumerable .. PatternPropertyRead Current {} { + var o_list i + return [lindex $o_list $i] + } + >IEnumerable .. PatternMethod MoveNext {} { + var i + incr i + } + >IEnumerable .. PatternMethod Reset {} { + var i + set i 0 + } +} + +#-------------------------------------------------- +namespace eval ::pattern::ms { + ::>pattern .. Create >Enumerator + >Enumerator .. PatternVariable o_enumerable + + >Enumerator .. Constructor {IEnumerable_object} { + var o_enumerable + set o_enumerable $IEnumerable_object + } + + >Enumerator .. PatternMethod atEnd {} { + var i o_list + return [expr {$i >= ([llength $o_list] -1)} ] + } + >Enumerator .. PatternMethod moveNext {} { + var i + incr i + } + >Enumerator .. PatternMethod moveFirst {} { + var i + set i 0 + } + >Enumerator .. PatternMethod item {} { + var i o_list + return [lindex $o_list $i] + } +} + + +#-------------------------------------------------- +namespace eval ::pattern::ms { + ::>pattern .. Create >textstream + >textstream .. PatternVariable o_fd ;#file descriptor + + >textstream .. Constructor {args} { + set opts [dict merge { + -mode r + } $args] + + if {([dict get $opts -mode] eq "r") && ![file exists [dict get $opts -path]]} { + error "file [dict get $opts -path] not found" + } + + set o_fd [open [dict get $opts -path] [dict get $opts -mode]] + return + } + + >textstream .. PatternMethod Write {data} { + var o_fd + puts -nonewline $o_fd $data + } + >textstream .. PatternMethod WriteLine {{line ""}} { + var o_fd + puts $o_fd $line + } + >textstream .. PatternMethod WriteBlankLines {howmany} { + var o_fd + #!todo - work out proper line-ending and write in single call. + if {$howmany > 0} { + for {set i 0} {$i < $howmany} {incr i} { + puts $o_fd "" + } + } + } + >textstream .. PatternMethod Read {{numbytes ""}} { + var o_fd + if {[string length $numbytes]} { + return [read $o_fd $numbytes] + } else { + return [read $o_fd] + } + } + >textstream .. PatternMethod ReadLine {} { + var o_fd + return [gets $o_fd] + } + >textstream .. PatternMethod ReadAll {} { + var o_fd + return [read $o_fd] ;#don't use size argument - we can't be sure it hasn't changed since opening (?) + } + >textstream .. PatternMethod Skip {numchars} { + var o_fd + seek $o_fd $numchars current + } + >textstream .. PatternMethod SkipLine {} { + var o_fd + gets $o_fd + return + } + + >textstream .. PatternMethod Close {} { + var o_fd + close $o_fd + } +} + +#------------------------------------------------------------------------------ +# https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/file-object +namespace eval ::pattern::ms { + ::>pattern .. Create >fso_file + >fso_file .. PatternVariable o_path + >fso_file .. Constructor {args} { + var this o_path + set this @this@ + + set opts [dict merge { + + } $args] + + if {![file exists [dict get $opts -path]]} { + error "cannot find file '[dict get $opts -path]'" + } + if {![file isfile [dict get $opts -path]]} { + error "path '[dict get $opts -path]' does not appear to be a file" + } + + set o_path [dict get $opts -path] + + return + } + >fso_file .. PatternProperty Name + >fso_file .. PatternPropertyRead Name {} { + var o_path + return [file tail $o_path] ;#??? + } + >fso_file .. PatternPropertyWrite Name {newname} { + var o_path + file rename $o_path [file dirname $o_path]/$newname + return + } + >fso_file .. PatternProperty Path + >fso_file .. PatternPropertyRead Path {} { + var o_path + return $o_path + } + +} + + +#------------------------------------------------------------------------------ +namespace eval ::pattern::ms { + ::>pattern .. Create >fso_folder + >fso_folder .. PatternVariable o_path + >fso_folder .. PatternVariable o_files ;#collection + + >fso_folder .. Constructor {args} { + var this ns o_path o_files + + set this @this@ + set ns [$this .. Namespace] + + set opts [dict merge { + + } $args] + + if {![file exists [dict get $opts -path]]} { + error "cannot find folder '[dict get $opts -path]'" + } + if {![file isdirectory [dict get $opts -path]]} { + error "path '[dict get $opts -path]' does not appear to be a folder" + } + + set o_path [dict get $opts -path] + + set o_files [::patternlib::>collection .. Create ${ns}::>col_files] + + return + } + + + #!todo - what happens to the object? destroy it? + >fso_folder .. PatternMethod Delete {{force 0}} { + var this o_path + if {$force} { + file delete -force $o_path + } else { + file delete $o_path + } + + #?? + # $this .. Destroy + return + } + + >fso_folder .. PatternProperty DateCreated + >fso_folder .. PatternPropertyRead DateCreated {} { + var o_path + file stat $o_path info + return $info(ctime) + } + >fso_folder .. PatternProperty DateLastAccessed + >fso_folder .. PatternPropertyRead DateLastAccessed {} { + var o_path + return [file atime $o_path] + } + >fso_folder .. PatternProperty DateLastModified + >fso_folder .. PatternPropertyRead DateLastModified {} { + var o_path + return [file mtime $o_path] + } + + >fso_folder .. PatternProperty Files + >fso_folder .. PatternPropertyRead Files {} { + var ns o_path objectcounter o_files + set filenames [glob -dir $o_path -type f -tail *] + lappend filenames {*}[glob -dir $o_path -types {f hidden} -tail *] + + set NEW [::pattern::ms::>fso_file .. Create .] + set files [list] + + set superfluous [struct::set difference [$o_files . names] $filenames] + foreach doomed $superfluous { + set f [$o_files . item $doomed] + $f .. Destroy + $o_files . del $doomed + } + + set missing [struct::set difference $filenames [$o_files . names]] + foreach fname $missing { + if {[catch { + set fobj [$NEW ${ns}::>fl_[incr objectcounter] -path $o_path/$fname] + } errM]} { + #There can exist characterSpecial files such as 'nul' that aren't identified as file or directory by Tcl 'file isfile' or 'file isdirectory' + # yet were picked up by glob + #(these shouldn't really exist - but can be accidentally created) + #we don't want an error in creating an >fso_file for this to stop us accessing any other files in the folder + #but we should at least be loud about it by emitting the error to stderr + puts stder " + } + $o_files . add [$NEW ${ns}::>fl_[incr objectcounter] -path $o_path/$fname] $fname + } + + return [$o_files . items] + } +} + + +#------------------------------------------------------------------------------ +#vba and vb6 File System Object (used the same COM component - Microsoft Scripting Runtime library scrrun.dll) +namespace eval ::pattern::ms { + ::>pattern .. Create >fso + + >fso .. PatternVariable objectcounter ;# + >fso .. Constructor {args} { + var this ns objectcounter + set this @this@ + set ns [$this .. Namespace] + + set objectcounter 0 + } + + >fso .. PatternMethod CreateTextFile {path {bool 1}} { + var ns objectcounter + set ts [::pattern::ms::>textstream .. Create ${ns}::>ts_[incr objectcounter] -path $path -mode w] + return $ts + } + + >fso .. PatternMethod OpenTextFile {path mode {bool 1}} { + var ns objectcounter + + switch -- [string tolower $mode] { + 1 - + forreading { + set md r + } + 2 - + forwriting { + set md w + } + 8 - + forappending { + set md a + } + default { + error "unknown file mode - $mode" + } + } + set ts [::pattern::ms::>textstream .. Create ${ns}::>ts_[incr objectcounter] -mode $md -path $path] + return $ts + } + + >fso .. PatternMethod GetFolder {path} { + var ns objectcounter + + set fld [::pattern::ms::>fso_folder .. Create ${ns}::>fld_[incr objectcounter] -path $path] + return $fld + } + >fso .. PatternProperty Drives + >fso .. PatternPropertyRead Drives {} { + var ns + error "unimplemented" + #todo >fso_drive object and collection + } +} + diff --git a/src/vendormodules/pattern2-2.0.tm b/src/vendormodules/pattern2-2.0.tm new file mode 100644 index 00000000..28d415ab --- /dev/null +++ b/src/vendormodules/pattern2-2.0.tm @@ -0,0 +1,911 @@ +#PATTERN +# - A prototype-based Object system. +# +# Julian Noble 2003 +# License: Public domain +# + +# "I need pattern" - Lexx Series 1 Episode 3 - Eating Pattern. +# +# +# Pattern uses a mixture of class-based and prototype-based object instantiation. +# +# A pattern object has 'properties' and 'methods' +# The system makes a distinction between them with regards to the access syntax for write operations, +# and yet provides unity in access syntax for read operations. +# e.g >object . myProperty +# will return the value of the property 'myProperty' +# >ojbect . myMethod +# will return the result of the method 'myMethod' +# contrast this with the write operations: +# set [>object . myProperty .] blah +# >object . myMethod blah +# however, the property can also be read using: +# set [>object . myProperty .] +# Note the trailing . to give us a sort of 'reference' to the property. +# this is NOT equivalent to +# set [>object . myProperty] +# This last example is of course calling set against a standard variable whose name is whatever value is returned by reading the property +# i.e it is equivalent in this case to: set blah + +#All objects are represented by a command, the name of which contains a leading ">". +#Any commands in the interp which use this naming convention are assumed to be a pattern object. +#Use of non-pattern commands containing this leading character is not supported. (Behaviour is undefined) + +#All user-added properties & methods of the wrapped object are accessed +# using the separator character "." +#Metamethods supplied by the patterm system are accessed with the object command using the metamethod separator ".." +# e.g to instantiate a new object from an existing 'pattern' (the equivalent of a class or prototype) +# you would use the 'Create' metamethod on the pattern object like so: +# >MyFactoryClassOrPrototypeLikeThing .. Create >NameOfNewObject +# '>NameOfNewObject' is now available as a command, with certain inherited methods and properties +# of the object it was created from. ( + + +#The use of the access-syntax separator character "." allows objects to be kept +# 'clean' in the sense that the only methods &/or properties that can be called this way are ones +# the programmer(you!) put there. Existing metamethods such as 'Create' are accessed using a different syntax +# so you are free to implement your own 'Create' method on your object that doesn't conflict with +# the metamethod. + +#Chainability (or how to violate the Law of Demeter!) +#The . access-syntax gives TCL an OO syntax more closely in line with many OO systems in other +# languages such as Python & VB, and allows left to right keyboard-entry of a deeply nested object-reference +# structure, without the need to regress to enter matching brackets as is required when using +# standard TCL command syntax. +# ie instead of: +# [[[object nextObject] getItem 4] getItem [chooseItemNumber]] doSomething +# we can use: +# >object . nextObject . getItem 4 . getItem [chooseItemNumber] . doSomething +# +# This separates out the object-traversal syntax from the TCL command syntax. + +# . is the 'traversal operator' when it appears between items in a commandlist +# . is the 'reference operator' when it is the last item in a commandlist +# , is the 'index traversal operator' (or 'nest operator') - mathematically it marks where there is a matrix 'partition'. +# It marks breaks in the multidimensional structure that correspond to how the data is stored. +# e.g obj . arraydata x y , x1 y1 z1 +# represents an element of a 5-dimensional array structured as a plane of cubes +# e.g2 obj . arraydata x y z , x1 y1 +# represents an element of a 5-dimensional array structured as a cube of planes +# The underlying storage for e.g2 might consist of something such as a Tcl array indexed such as cube($x,$y,$z) where each value is a patternlib::>matrix object with indices x1 y1 +# .. is the 'meta-traversal operator' when it appears between items in a commandlist +# .. is the 'meta-info operator'(?) when it is the last item in a commandlist + + +#!todo - Duck Typing: http://en.wikipedia.org/wiki/Duck_typing +# implement iStacks & pStacks (interface stacks & pattern stacks) + +#see also: Using namsepace ensemble without a namespace: http://wiki.tcl.tk/16975 + + +#------------------------------------------------------------ +# System objects. +#------------------------------------------------------------ +#::pp::Obj-1 ::p::internals::>metaface +#::pp::Obj0 ::p::ifaces::>null +#::pp::Obj1 ::>pattern +#------------------------------------------------------------ + +#TODO + +#investigate use of [namespace path ... ] to resolve command lookup (use it to chain iStacks?) + + +#CHANGES +#2018-09 - v 1.2.2 +# varied refactoring +# Changed invocant datastructure curried into commands (the _ID_ structure) +# Changed MAP structure to dict +# Default Method no longer magic "item" - must be explicitly set with .. DefaultMethod (or .. PatternDefaultMethod for patterns) +# updated test suites +#2018-08 - v 1.2.1 +# split ::p::predatorX functions into separate files (pkgs) +# e.g patternpredator2-1.0.tm +# patternpredator1-1.0 - split out but not updated/tested - probably obsolete and very broken +# +#2017-08 - v 1.1.6 Fairly big overhaul +# New predator function using coroutines +# Added bang operator ! +# Fixed Constructor chaining +# Added a few tests to test::pattern +# +#2008-03 - preserve ::errorInfo during var writes + +#2007-11 +#Major overhaul + new functionality + new tests v 1.1 +# new dispatch system - 'predator'. +# (preparing for multiple interface stacks, multiple invocants etc) +# +# +#2006-05 +# Adjusted 'var' expansion to use the new tcl8.5 'namespace upvar $ns v1 n1 v2 n2 ... ' feature. +# +#2005-12 +# Adjusted 'var' expansion in method/constructor etc bodies to be done 'inline' where it appears rather than aggregated at top. +# +# Fixed so that PatternVariable default applied on Create. +# +# unified interface/object datastructures under ::p:::: instead of seperate ::p::IFACE:::: +# - heading towards multiple-interface objects +# +#2005-10-28 +# 1.0.8.1 passes 80/80 tests +# >object .. Destroy - improved cleanup of interfaces & namespaces. +# +#2005-10-26 +# fixes to refsync (still messy!) +# remove variable traces on REF vars during .. Destroy +# passes 76/76 +# +#2005-10-24 +# fix objectRef_TraceHandler so that reading a property via an object reference using array syntax will call a PropertyRead function if defined. +# 1.0.8.0 now passes 75/76 +# +#2005-10-19 +# Command alias introduced by @next@ is now placed in the interfaces namespace. (was unnamespaced before) +# changed IFACE array names for level0 methods to be m-1 instead of just m. (now consistent with higher level m-X names) +# 1.0.8.0 (passes 74/76) +# tests now in own package +# usage: +# package require test::pattern +# test::p::list +# test::p::run ?nameglob? ?-version ? +# +#2005-09?-12 +# +# fixed standalone 'var' statement in method bodies so that no implicit variable declarations added to proc. +# fixed @next@ so that destination method resolved at interface compile time instead of call time +# fixed @next@ so that on Create, .. PatternMethod x overlays existing method produced by a previous .. PatternMethod x. +# (before, the overlay only occured when '.. Method' was used to override.) +# +# +# miscellaneous tidy-ups +# +# 1.0.7.8 (passes 71/73) +# +#2005-09-10 +# fix 'unknown' system such that unspecified 'unknown' handler represented by lack of (unknown) variable instead of empty string value +# this is so that a mixin with an unspecified 'unknown' handler will not undo a lowerlevel 'unknown' specificier. +# +#2005-09-07 +# bugfix indexed write to list property +# bugfix Variable default value +# 1.0.7.7 (passes 70/72) +# fails: +# arrayproperty.test - array-entire-reference +# properties.test - property_getter_filter_via_ObjectRef +# +#2005-04-22 +# basic fix to PatternPropertyRead dispatch code - updated tests (indexed case still not fixed!) +# +# 1.0.7.4 +# +#2004-11-05 +# basic PropertyRead implementation (non-indexed - no tests!) +# +#2004-08-22 +# object creation speedups - (pattern::internals::obj simplified/indirected) +# +#2004-08-17 +# indexed property setter fixes + tests +# meta::Create fixes - state preservation on overlay (correct constructor called, property defaults respect existing values) +# +#2004-08-16 +# PropertyUnset & PatternPropertyUnset metaMethods (filter method called on property unset) +# +#2004-08-15 +# reference syncing: ensure writes to properties always trigger traces on property references (+ tests) +# - i.e method that updates o_myProp var in >myObj will cause traces on [>myObj . myProp .] to trigger +# - also trigger on curried traces to indexed properties i.e list and array elements. +# - This feature presumably adds some overhead to all property writes - !todo - investigate desirability of mechanism to disable on specific properties. +# +# fix (+ tests) for ref to multiple indices on object i.e [>myObj key1 key2 .] +# +#2004-08-05 +# add PropertyWrite & PatternPropertyWrite metaMethods - (filter method called on property write) +# +# fix + add tests to support method & property of same name. (method precedence) +# +#2004-08-04 +# disallow attempt to use method reference as if it were a property (raise error instead of silently setting useless var) +# +# 1.0.7.1 +# use objectref array access to read properties even when some props unset; + test +# unset property using array access on object reference; + test +# +# +#2004-07-21 +# object reference changes - array property values appear as list value when accessed using upvared array. +# bugfixes + tests - properties containing lists (multidimensional access) +# +#1.0.7 +# +#2004-07-20 +# fix default property value append problem +# +#2004-07-17 +# add initial implementation of 'Unknown' and 'PatternUnknown' meta-methods +# ( +# +#2004-06-18 +# better cleanup on '>obj .. Destroy' - recursively destroy objects under parents subnamespaces. +# +#2004-06-05 +# change argsafety operator to be anything with leading - +# if standalone '-' then the dash itself is not added as a parameter, but if a string follows '-' +# i.e tkoption style; e.g -myoption ; then in addition to acting as an argsafety operator for the following arg, +# the entire dash-prefixed operator is also passed in as an argument. +# e.g >object . doStuff -window . +# will call the doStuff method with the 2 parameters -window . +# >object . doStuff - . +# will call doStuff with single parameter . +# >object . doStuff - -window . +# will result in a reference to the doStuff method with the argument -window 'curried' in. +# +#2004-05-19 +#1.0.6 +# fix so custom constructor code called. +# update Destroy metamethod to unset $self +# +#1.0.4 - 2004-04-22 +# bug fixes regarding method specialisation - added test +# +#------------------------------------------------------------ + +package provide pattern2 [namespace eval pattern {variable version; set version 2.0}] +package require patterncmd ;#utility/system diagnostic commands (may be used by metaface lib etc) +package require cmdline + +package require patterndispatcher + +namespace eval pattern { + variable initialised 0 +} + + + +namespace eval pp { + #this is also the interp alias namespace. (object commands created here , then renamed into place) + #the object aliases are named as incrementing integers.. !todo - consider uuids? + variable ID 0 + namespace eval func {} +} + + +#!store all interface objects here? +namespace eval ::pp::ifaces {} + + +proc ::pp::assert {condition errmsg} { + if {![uplevel 1 expr $condition]} { + return -code error "assertion failed. condition:'$condition' msg:'$errmsg'" + } +} +#proc ::pp::assert args {} + +proc ::pp::get_new_object_id {} { + tailcall incr ::pp::ID + #tailcall ::pattern::new_uuid +} + + +#create a new minimal object - with no interfaces or patterns. +proc ::pp::func::new_object {obj {OID ""}} { + puts stderr "(::pp::func::new_object) obj:$obj OID:$OID" + + if {[string range $obj 0 1] ne "::"} { + set nsbase [uplevel 1 [list namespace current]] + if {$nsbase eq "::"} { + set obj ::$obj + } else { + set obj ${nsbase}::$obj + } + } + + if {[info object isa object $obj]} { + puts stderr "(::pp::func::new_object) Object $obj already exists " + } + + if {$OID eq ""} { + set OID [::pp::get_new_object_id] + } + + set main_ns ::pp::Obj${OID} + if {[namespace exists $main_ns]} { + error "(::pp::func::new_object) Cannot create Object with id:'$OID' - corresponding namespace already exists" + } + + + + + set default_method {} + set object_command $obj + #set INVOCANTRECORD [list $OID $main_ns $default_method $object_command {}] + + set invocantD [list id $OID ns $main_ns defaultmethod $default_method object $object_command] + + # _ID_ structure + #set _InvocantData_ [dict create i [dict create this [list $INVOCANTRECORD]] context ""] + set _InvocantData_ [dict create i [dict create this [list $invocantD]] context ""] + + #must create main varspace first as it is also the parent namespace for all varspaces + set vs_main [::pp::varspace_main create ::pp::Obj${OID} [set varspacename ""] $_InvocantData_] + + set vs_meta [::pp::varspace_meta create ::pp::Obj${OID}::_meta _meta $_InvocantData_] + + + puts stderr "\t(::pp::func::new_object) --- about to call pp::dispatcher create $obj $_InvocantData_ main" + pp::dispatcher create $obj $_InvocantData_ "main" + + return $obj +} + +proc ::pp::func::new_dispatcher {obj _InvocantData_ apiname} { + pp::dispatcher create $obj $_InvocantData_ $apiname +} + + + +#aliased from ::p::${OID}:: +# called when no DefaultMethod has been set for an object, but it is called with indices e.g >x something +proc ::pp::func::no_default_method {_ID_ args} { + puts stderr "no_default_method _ID_:'$_ID_' args:'$args'" + lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command wrapped + tailcall error "No default method on object $object_command. (To get or set, use: $object_command .. DefaultMethod ?methodname?)" +} + + + +#>x .. Create >y +# ".." is special case equivalent to "._." +# (whereas in theory it would be ".default.") +# "." is equivalent to ".default." is equivalent to ".default.default." (...) + +#>x ._. Create >y +#>x ._.default. Create >y ??? +# +# + +# create object using 'blah' as source interface-stack ? +#>x .blah. .. Create >y +#>x .blah,_. ._. Create .iStackDestination. >y + + + +# +# ">x .blah,_." is a reference(cast) to >x that contains only the iStacks in the order listed. i.e [list blah _] +# the 1st item, blah in this case becomes the 'default' iStack. +# +#>x .*. +# cast to object with all iStacks +# +#>x .*,!_. +# cast to object with all iStacks except _ +# +# --------------------- +#!todo - MultiMethod support via transient and persistent object conglomerations. Operators '&' & '@' +# - a persistent conglomeration will have an object id (OID) and thus associated namespace, whereas a transient one will not. +# +#eg1: >x & >y . some_multi_method arg arg +# this is a call to the MultiMethod 'some_multi_method' with 2 objects as the invocants. ('>x & >y' is a transient conglomeration of the two objects) +# No explicit 'invocation role' is specified in this call - so it gets the default role for multiple invocants: 'these' +# The invocant signature is thus {these 2} +# (the default invocation role for a standard call on a method with a single object is 'this' - with the associated signature {this 1}) +# Invocation roles can be specified in the call using the @ operator. +# e.g >x & >y @ points . some_multi_method arg arg +# The invocant signature for this is: {points 2} +# +#eg2: {*}[join $objects &] @ objects & >p @ plane . move $path +# This has the signature {objects n plane 1} where n depends on the length of the list $objects +# +# +# To get a persistent conglomeration we would need to get a 'reference' to the conglomeration. +# e.g set pointset [>x & >y .] +# We can now call multimethods on $pointset +# + + + + + if {[namespace which ::pp::ifaces>null] eq ""} { + set ::pp::ID 4 ;#0,1,2,3 reserved for null interface,>pattern, >ifinfo & ::p::>interface + + #OID = 0 + ::pp::func::new_object ::pp::ifaces::>null 0 + + ::pp::func::new_object ::>pattern 1 + + #'class' for ::pp::ifaces::>x instances + ::pp::func::new_object ::pp::>interface 3 + + } + +#NOOP - for compatibility with libraries which still call it +proc ::pattern::init {args} { +} + + +proc ::pattern::initXXX {args} { + if {[set ::pattern::initialised]} { + if {[llength $args]} { + #if callers want to avoid this error, they can do their own check of $::pattern::initialised + error "pattern package is already initialised. Unable to apply args: $args" + } else { + return 1 + } + } + set ::pp::ID 4 ;#0,1,2,3 reserved for null interface,>pattern, >ifinfo & ::p::>interface + + #OID = 0 + ::pp::func::new_object ::pp::ifaces::>null 0 + + ::pp::func::new_object ::>pattern 1 + + #'class' for ::pp::ifaces::>x instances + ::pp::func::new_object ::pp::>interface 3 + + #::pp::>interface ## PatternSystem . add_pattern_interface 2 + + #add to constructor? + #::pp::Obj${o_OID}::_iface API(PatternInternal)add_tcloo_interface_on_api "varspace_iface" "pattern::IPatternInterface" + + set ::pattern::initialised 1 +} + + +# >pattern has object ID 1 +# meta interface has object ID 0 +proc ::pattern::init2 args { + if {[set ::pattern::initialised]} { + if {[llength $args]} { + #if callers want to avoid this error, they can do their own check of $::pattern::initialised + error "pattern package is already initialised. Unable to apply args: $args" + } else { + return 1 + } + } + set ::pp::ID 4 ;#0,1,2,3 reserved for null interface,>pattern, >ifinfo & ::p::>interface + + #create metaface - IID = -1 - also OID = -1 + # all objects implement this special interface - accessed via the .. operator. + package require metaface + + + + #OID = 0 + ::pp::func::new_object ::p::ifaces::>null 0 + + #? null object has itself as level0 & level1 interfaces? + #set ::p::ifaces::>null [list [list 0 ::p::ifaces::>null item] [list [list 0] [list 0]] [list {} {}]] + + #null interface should always have 'usedby' members. It should never be extended. + array set ::p::0::_iface::o_usedby [list i-1 ::p::internals::>metaface i0 ::p::ifaces::>null i1 ::>pattern] ;#'usedby' array + set ::p::0::_iface::o_open 0 + + set ::p::0::_iface::o_constructor [list] + set ::p::0::_iface::o_variables [list] + set ::p::0::_iface::o_properties [dict create] + set ::p::0::_iface::o_methods [dict create] + set ::p::0::_iface::o_varspace "" + set ::p::0::_iface::o_varspaces [list] + array set ::p::0::_iface::o_definition [list] + set ::p::0::_iface::o_propertyunset_handlers [dict create] + + + + + ############################### + # OID = 1 + # >pattern + ############################### + ::pp::func::new_object ::>pattern 1 + + + + set _self ::pattern + + #set IFID [::p::internals::new_interface 1] ;#level 0 interface usedby object 1 + #set IFID_1 [::p::internals::new_interface 1] ;#level 1 interface usedby object 1 + + + + #1)this object references its interfaces + #lappend ID $IFID $IFID_1 + + + #set body [string map [::list @self@ ::>pattern @_self@ ::pattern @self_ID@ 0 @itemCmd@ item] $::p::internals::OBJECTCOMMAND] + #proc ::>pattern args $body + + + + + ####################################################################################### + #OID = 2 + # >ifinfo interface for accessing interfaces. + # + ::p::internals::new_object ::p::ifaces::>2 "" 2 ;#>ifinfo object + set ::p::2::_iface::o_constructor [list] + set ::p::2::_iface::o_variables [list] + set ::p::2::_iface::o_properties [dict create] + set ::p::2::_iface::o_methods [dict create] + set ::p::2::_iface::o_varspace "" + set ::p::2::_iface::o_varspaces [list] + array set ::p::2::_iface::o_definition [list] + set ::p::2::_iface::o_open 1 ;#open for extending + + ::p::ifaces::>2 .. AddInterface 2 + + #Manually create a minimal >ifinfo implementation using the same general pattern we use for all method implementations + #(bootstrap because we can't yet use metaface methods on it) + + + + proc ::p::2::_iface::isOpen.1 {_ID_} { + return $::p::2::_iface::o_open + } + interp alias {} ::p::2::_iface::isOpen {} ::p::2::_iface::isOpen.1 + + proc ::p::2::_iface::isClosed.1 {_ID_} { + return [expr {!$::p::2::_iface::o_open}] + } + interp alias {} ::p::2::_iface::isClosed {} ::p::2::_iface::isClosed.1 + + proc ::p::2::_iface::open.1 {_ID_} { + set ::p::2::_iface::o_open 1 + } + interp alias {} ::p::2::_iface::open {} ::p::2::_iface::open.1 + + proc ::p::2::_iface::close.1 {_ID_} { + set ::p::2::_iface::o_open 0 + } + interp alias {} ::p::2::_iface::close {} ::p::2::_iface::close.1 + + + #proc ::p::2::_iface::(GET)properties.1 {_ID_} { + # set ::p::2::_iface::o_properties + #} + #interp alias {} ::p::2::_iface::(GET)properties {} ::p::2::_iface::(GET)properties.1 + + #interp alias {} ::p::2::properties {} ::p::2::_iface::(GET)properties + + + #proc ::p::2::_iface::(GET)methods.1 {_ID_} { + # set ::p::2::_iface::o_methods + #} + #interp alias {} ::p::2::_iface::(GET)methods {} ::p::2::_iface::(GET)methods.1 + #interp alias {} ::p::2::methods {} ::p::2::_iface::(GET)methods + + + + + + #link from object to interface (which in this case are one and the same) + + #interp alias {} ::p::2::isOpen {} ::p::2::_iface::isOpen [::p::ifaces::>2 --] + #interp alias {} ::p::2::isClosed {} ::p::2::_iface::isClosed [::p::ifaces::>2 --] + #interp alias {} ::p::2::open {} ::p::2::_iface::open [::p::ifaces::>2 --] + #interp alias {} ::p::2::close {} ::p::2::_iface::close [::p::ifaces::>2 --] + + interp alias {} ::p::2::isOpen {} ::p::2::_iface::isOpen + interp alias {} ::p::2::isClosed {} ::p::2::_iface::isClosed + interp alias {} ::p::2::open {} ::p::2::_iface::open + interp alias {} ::p::2::close {} ::p::2::_iface::close + + + #namespace eval ::p::2 "namespace export $method" + + ####################################################################################### + + + + + + + set ::pattern::initialised 1 + + + ::p::internals::new_object ::p::>interface "" 3 + #create a convenience object on which to manipulate the >ifinfo interface + #set IF [::>pattern .. Create ::p::>interface] + set IF ::p::>interface + + + #!todo - put >ifinfo on a separate pStack so that end-user can more freely treat interfaces as objects? + # (or is forcing end user to add their own pStack/iStack ok .. ?) + # + ::p::>interface .. AddPatternInterface 2 ;# + + ::p::>interface .. PatternVarspace _iface + + ::p::>interface .. PatternProperty methods + ::p::>interface .. PatternPropertyRead methods {} { + varspace _iface + var {o_methods mmm} + return $mmm + } + ::p::>interface .. PatternProperty properties + ::p::>interface .. PatternPropertyRead properties {} { + varspace _iface + var o_properties + return $o_properties + } + ::p::>interface .. PatternProperty variables + + ::p::>interface .. PatternProperty varspaces + + ::p::>interface .. PatternProperty definition + + ::p::>interface .. Constructor {{usedbylist {}}} { + #var this + #set this @this@ + #set ns [$this .. Namespace] + #puts "-> creating ns ${ns}::_iface" + #namespace eval ${ns}::_iface {} + + varspace _iface + var o_constructor o_variables o_properties o_methods o_definition o_usedby o_varspace o_varspaces + + set o_constructor [list] + set o_variables [list] + set o_properties [dict create] + set o_methods [dict create] + set o_varspaces [list] + array set o_definition [list] + + foreach usedby $usedbylist { + set o_usedby(i$usedby) 1 + } + + + } + ::p::>interface .. PatternMethod isOpen {} { + varspace _iface + var o_open + + return $o_open + } + ::p::>interface .. PatternMethod isClosed {} { + varspace _iface + var o_open + + return [expr {!$o_open}] + } + ::p::>interface .. PatternMethod open {} { + varspace _iface + var o_open + set o_open 1 + } + ::p::>interface .. PatternMethod close {} { + varspace _iface + var o_open + set o_open 0 + } + ::p::>interface .. PatternMethod refCount {} { + varspace _iface + var o_usedby + return [array size o_usedby] + } + + set ::p::2::_iface::o_open 1 + + + + + + uplevel #0 {package require patternlib} + return 1 +} + + + +#detect attempt to treat a reference to a method as a property +proc ::pp::func::commandrefMisuse_TraceHandler {OID field args} { + #puts "commandrefMisuse_TraceHandler fired OID:$OID field:$field args:$args" + lassign [lrange $args end-2 end] vtraced vidx op + #NOTE! cannot rely on vtraced as it may have been upvared + + switch -- $op { + write { + error "$field is not a property" "property ref write failure for property $field (OID: $OID refvariable: [lindex $args 0])" + } + unset { + #!todo - monitor stat of Tcl bug# 1911919 - when/(if?) fixed - reinstate 'unset' trace + #trace add variable $traced {read write unset} [concat ::pp::func::commandrefMisuse_TraceHandler $OID $field $args] + + #!todo - don't use vtraced! + trace add variable $vtraced {read write unset array} [concat ::pp::func::commandrefMisuse_TraceHandler $OID $field $args] + + #pointless raising an error as "Any errors in unset traces are ignored" + #error "cannot unset. $field is a method not a property" + } + read { + error "$field is not a property (args $args)" "property ref read failure for property $field (OID: $OID refvariable: [lindex $args 0])" + } + array { + error "$field is not a property (args $args)" "property ref use as array failure for property $field (OID: $OID refvariable: [lindex $args 0])" + #error "unhandled operation in commandrefMisuse_TraceHandler - got op:$op expected read,write,unset. OID:$OID field:$field args:$args" + } + } + + return +} + + + + +#!todo - review calling-points for make_dispatcher.. probably being called unnecessarily at some points. +# +# The 'dispatcher' is an object instance's underlying object command. +# + +#proc ::p::make_dispatcher {obj ID IFID} { +# proc [string map {::> ::} $obj] {{methprop INFO} args} [string map [::list @IID@ $IFID @oid@ $ID] { +# ::p::@IID@ $methprop @oid@ {*}$args +# }] +# return +#} + + + + +################################################################################################################################################ +################################################################################################################################################ +################################################################################################################################################ + + +#force 1 will extend an interface even if shared. (??? why is this necessary here?) +#if IID empty string - create the interface. +proc ::pp::func::expand_interface {IID {force 0}} { + #puts stdout ">>> expand_interface $IID [info level -1]<<<" + if {![string length $IID]} { + set iid [expr {$::p::ID + 1}] + ::pp::>interface .. Create ::pp::ifaces::>$iid + return $iid + } else { + if {[set ::pp::Obj${IID}::_iface::o_open]} { + #interface open for extending - shared or not! + return $IID + } + error "temporary error. Interface can't be expanded. Not implemented" + if {[array size ::pp::Obj${IID}::_iface::o_usedby] > 1} { + #upvar #0 ::p::${IID}::_iface::o_usedby prev_usedby + + #oops.. shared interface. Copy before specialising it. + set prev_IID $IID + + set IID [expr {$::pp::ID + 1}] + ::pp::>interface .. Create ::pp::ifaces::>$IID + + ::pp::func::linkcopy_interface $prev_IID $IID + #assert: prev_usedby contains at least one other element. + } + #whether copied or not - mark as open for extending. + set ::pp::Obj${IID}::_iface::o_open 1 + return $IID + } +} + +#params: old - old (shared) interface ID +# new - new interface ID +proc ::pp::func::linkcopy_interface {old new} { + #puts stderr " ** ** ** linkcopy_interface $old $new" + set ns_old ::pp::Obj${old}::_iface + set ns_new ::pp::Obj${new}::_iface + + + + foreach nsmethod [info commands ${ns_old}::*.1] { + #puts ">>> adding $nsmethod to iface $new" + set tail [namespace tail $nsmethod] + set method [string range $tail 0 end-2] ;#strip .1 + + if {![llength [info commands ${ns_new}::$method]]} { + + set oldhead [interp alias {} ${ns_old}::$method] ;#the 'head' of the cmdchain that it actually points to ie $method.$x where $x >=1 + + #link from new interface namespace to existing one. + #(we assume that since ${ns_new}::$method didn't exist, that all the $method.$x chain slots are empty too...) + #!todo? verify? + #- actual link is chainslot to chainslot + interp alias {} ${ns_new}::$method.1 {} $oldhead + + #!todo - review. Shouldn't we be linking entire chain, not just creating a single .1 pointer to the old head? + + + #chainhead pointer within new interface + interp alias {} ${ns_new}::$method {} ${ns_new}::$method.1 + + namespace eval $ns_new "namespace export $method" + + #if {[string range $method 0 4] ni {(GET) (SET) (UNSE (CONS }} { + # lappend ${ns_new}::o_methods $method + #} + } else { + if {$method eq "(VIOLATE)"} { + #ignore for now + #!todo + continue + } + + #!todo - handle how? + #error "command $cmd already exists in interface $new" + + #warning - existing chainslot will be completely shadowed by linked method. + # - existing one becomes unreachable. #!todo review!? + + + error "linkcopy_interface $old -> $new - chainslot shadowing not implemented (method $method already exists on target interface $new)" + + } + } + + + #foreach propinf [set ${ns_old}::o_properties] { + # lassign $propinf prop _default + # #interp alias {} ${ns_new}::(GET)$prop {} ::p::predator::getprop $prop + # #interp alias {} ${ns_new}::(SET)$prop {} ::p::predator::setprop $prop + # lappend ${ns_new}::o_properties $propinf + #} + + + set ${ns_new}::o_variables [set ${ns_old}::o_variables] + set ${ns_new}::o_properties [set ${ns_old}::o_properties] + set ${ns_new}::o_methods [set ${ns_old}::o_methods] + set ${ns_new}::o_constructor [set ${ns_old}::o_constructor] + + + set ::pp::${old}::_iface::o_usedby(i$new) linkcopy + + + #obsolete.? + #array set ::p::${new}:: [array get ::p::${old}:: ] + + + + #!todo - is this done also when iface compiled? + #namespace eval ::p::${new}::_iface {namespace ensemble create} + + + #puts stderr "copy_interface $old $new" + + #assume that the (usedby) data is now obsolete + #???why? + #set ${ns_new}::(usedby) [::list] + + #leave ::(usedby) reference in place for caller to change as appropriate - 'copy' + + return +} +################################################################################################################################################ +################################################################################################################################################ +################################################################################################################################################ + +#pattern::init + +#return $::pattern::version + +proc pp::repl {} { + set command "" + set prompt "% " + puts -nonewline stdout $prompt + flush stdout + while {[gets stdin line] >=0} { + append command "\n$line" + if {[info complete $command]} { + catch {uplevel #0 $command} result + puts stdout $result + set command "" + set prompt "% " + } else { + set prompt "(cont)% " + } + puts -nonewline stdout $prompt + flush stdout + } +} + +if {[info exists ::argv0] && [file dirname [file normalize [info script]/ ]] eq [file dirname [file normalize $argv0/]]} { + pp::repl +} + diff --git a/src/vendormodules/patterncipher-0.1.1.tm b/src/vendormodules/patterncipher-0.1.1.tm index 62b03cbc..0aa12476 100644 --- a/src/vendormodules/patterncipher-0.1.1.tm +++ b/src/vendormodules/patterncipher-0.1.1.tm @@ -37,7 +37,6 @@ package provide patterncipher [namespace eval patterncipher { package require ascii85 ;#tcllib package require pattern -::pattern::init ;# initialises (if not already) namespace eval ::patterncipher { namespace eval algo::txt { diff --git a/src/vendormodules/patterndispatcher-1.2.4.tm b/src/vendormodules/patterndispatcher-1.2.4.tm index 14194aee..373fe6d9 100644 --- a/src/vendormodules/patterndispatcher-1.2.4.tm +++ b/src/vendormodules/patterndispatcher-1.2.4.tm @@ -13,6 +13,7 @@ namespace eval pp { set no_operators_in_args [string trimright $no_operators_in_args " &"] ;#trim trailing spaces and ampersands #set no_operators_in_args {({.} ni $args) && ({,} ni $args) && ({..} ni $args)} + #todo - compare performance against algorithm in punk::lib::is_cachedlist_all_ni_list } package require TclOO diff --git a/src/vendormodules/test/pattern-1.2.8.tm b/src/vendormodules/test/pattern-1.2.8.tm new file mode 100644 index 00000000..b5cb7026 Binary files /dev/null and b/src/vendormodules/test/pattern-1.2.8.tm differ diff --git a/src/vendormodules/test/tomlish-1.1.5.tm b/src/vendormodules/test/tomlish-1.1.5.tm index 3ae60d42..f4f2b484 100644 Binary files a/src/vendormodules/test/tomlish-1.1.5.tm and b/src/vendormodules/test/tomlish-1.1.5.tm differ diff --git a/src/vendormodules/treeobj-1.3.1.tm b/src/vendormodules/treeobj-1.3.1.tm index b3e37eea..da60078a 100644 Binary files a/src/vendormodules/treeobj-1.3.1.tm and b/src/vendormodules/treeobj-1.3.1.tm differ diff --git a/src/vfs/_config/project_main.tcl b/src/vfs/_config/project_main.tcl index bcf54540..40446f82 100644 --- a/src/vfs/_config/project_main.tcl +++ b/src/vfs/_config/project_main.tcl @@ -1,4 +1,6 @@ +#source is at /src/vfs/_config/project_main.tcl + #This main script will consume a first argument of the form dev|os|internal # or any dash-delimited combination such as dev-os # diff --git a/src/vfs/_config/punk_main.tcl b/src/vfs/_config/punk_main.tcl index bc853604..14ad0e1c 100644 --- a/src/vfs/_config/punk_main.tcl +++ b/src/vfs/_config/punk_main.tcl @@ -1,4 +1,6 @@ +#source is at src/vfs/_config/punk_main.tcl + #This main script will consume a first argument of the form dev|os|internal # or any dash-delimited combination such as dev-os #